diff --git a/INSTALL.txt b/INSTALL.txt index 7ec805d61..8020aa47b 100644 --- a/INSTALL.txt +++ b/INSTALL.txt @@ -1,7 +1,7 @@ Installation instructions for Gambit-C ====================================== - [Time-stamp: <2008-12-23 09:06:13 feeley>] + [Time-stamp: <2009-02-11 11:12:55 feeley>] This directory contains a release of the Gambit-C Scheme programming @@ -140,6 +140,9 @@ The configure options which are specific to the Gambit-C system are: --enable-absolute-shared-libs shared libraries should be linked to using an absolute path + --enable-help-browser=BROWSER + use the specified browser to view documentation + requested through the help procedure or REPL The option --enable-cplusplus should be used when applications developped with the Gambit-C compiler are to be linked with code or diff --git a/bin/gambc-doc.bat.unix.in b/bin/gambc-doc.bat.unix.in new file mode 100644 index 000000000..5be36d5a2 --- /dev/null +++ b/bin/gambc-doc.bat.unix.in @@ -0,0 +1,73 @@ +#! /bin/sh + +# Script parameters are passed in the following environment variables: +# GAMBC_DOC_GAMBCDIR_BIN +# GAMBC_DOC_GAMBCDIR_DOC +# GAMBC_DOC_ARG1 +# GAMBC_DOC_ARG2 +# GAMBC_DOC_ARG3 +# GAMBC_DOC_ARG4 +# ... + +# echo GAMBC_DOC_GAMBCDIR_BIN = "${GAMBC_DOC_GAMBCDIR_BIN}" +# echo GAMBC_DOC_GAMBCDIR_DOC = "${GAMBC_DOC_GAMBCDIR_DOC}" +# echo GAMBC_DOC_ARG1 = "${GAMBC_DOC_ARG1}" +# echo GAMBC_DOC_ARG2 = "${GAMBC_DOC_ARG2}" +# echo GAMBC_DOC_ARG3 = "${GAMBC_DOC_ARG3}" +# echo GAMBC_DOC_ARG4 = "${GAMBC_DOC_ARG4}" + +find_in_path() # exe-name, sets `$exe' +{ + save_IFS="${IFS}"; IFS=":" + for dir in $PATH; do + if test -x "$dir/$1" -a ! -d "$dir/$1"; then + exe="$dir/$1"; IFS="$save_IFS"; return 0 + fi + done + exe=""; IFS="$save_IFS"; return 1 +} + +find_browser() # sets `$exe' +{ + if [ "@HELP_BROWSER@" != "" ]; then + browser_list="@HELP_BROWSER@" + else + browser_list="lynx firefox mozilla netscape osascript" + fi + + browser_list="${GAMBC_DOC_ARG3} $browser_list" + + for b in $browser_list; do + if find_in_path $b; then + browser=$b + return 0 + fi + done + return 1 +} + +operation_help() # sets `$exe' +{ + if find_browser; then + url="file://${GAMBC_DOC_GAMBCDIR_DOC}/gambit-c.html#${GAMBC_DOC_ARG4}" + case "$browser" in + osascript ) $exe <> gsc-cc-o.bat; \ fi +gambc-doc.bat: makefile + rm -f gambc-doc.bat + if test "@bat@" = ""; then \ + cp gambc-doc.bat.unix gambc-doc.bat; \ + chmod +x gambc-doc.bat; \ + else \ + cp gambc-doc.bat.windows gambc-doc.bat; \ + fi + six@exe@: makefile rm -f six@exe@ six@exe@.lnk if test "@bat@" = ""; then \ @@ -297,6 +307,7 @@ mostlyclean-pre: mostlyclean-post: rm -f gsc-cc-o.bat \ + gambc-doc.bat \ six@exe@ six@exe@.lnk \ gsi-script@bat@ \ gsi-script@bat@.lnk \ diff --git a/configure b/configure index 8f084b2e6..d8e8e8442 100755 --- a/configure +++ b/configure @@ -9,7 +9,7 @@ # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. # -# Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved. +# Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## @@ -800,6 +800,7 @@ ENABLE_SHARED ENABLE_ABSOLUTE_SHARED_LIBS ENABLE_VERSIONNED_LIBS emacsdir +HELP_BROWSER SET_MAKE LIBOBJS LTLIBOBJS' @@ -821,6 +822,7 @@ enable_ansi_c enable_symlinks enable_multiple_versions enable_absolute_shared_libs +enable_help_browser with_x ' ac_precious_vars='build_alias @@ -1493,6 +1495,8 @@ Optional Features: --enable-absolute-shared-libs shared libraries should be linked to using an absolute path (default is YES) + --enable-help-browser=BROWSER + Browser to use for help (default is to search) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] @@ -1587,7 +1591,7 @@ Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. -Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved. +Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. _ACEOF exit fi @@ -5434,6 +5438,18 @@ if test "$ENABLE_SHARED" != "yes"; then ENABLE_ABSOLUTE_SHARED_LIBS=no fi +############################################################################### +# +# Determine which browser to use for help. + +# Check whether --enable-help-browser was given. +if test "${enable_help_browser+set}" = set; then + enableval=$enable_help_browser; HELP_BROWSER=$enableval +else + HELP_BROWSER="" +fi + + ############################################################################### # # Check for C compiler. @@ -24790,6 +24806,7 @@ INSTALL_PROGRAM='$(rootfromhere)/install-sh -c -m 755' + { $as_echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 @@ -24824,7 +24841,7 @@ $as_echo "no" >&6; } fi -ac_config_files="$ac_config_files makefile include/makefile include/gambit.h lib/makefile lib/guide/guidepro lib/guide/makefile lib/guide/images/makefile gsi/makefile gsc/makefile bin/makefile misc/makefile doc/makefile tests/makefile examples/makefile examples/distr-comp/makefile examples/pi/makefile examples/ring/makefile examples/web-repl/makefile examples/web-server/makefile examples/tcltk/makefile examples/Xlib-simple/makefile examples/pthread/makefile examples/misc/makefile prebuilt/makefile prebuilt/macosx/makefile prebuilt/macosx/build-phase2 prebuilt/windows/makefile prebuilt/windows/build-phase2" +ac_config_files="$ac_config_files makefile include/makefile include/gambit.h lib/makefile lib/guide/guidepro lib/guide/makefile lib/guide/images/makefile gsi/makefile gsc/makefile bin/makefile bin/gambc-doc.bat.unix bin/gambc-doc.bat.windows misc/makefile doc/makefile tests/makefile examples/makefile examples/distr-comp/makefile examples/pi/makefile examples/ring/makefile examples/web-repl/makefile examples/web-server/makefile examples/tcltk/makefile examples/Xlib-simple/makefile examples/pthread/makefile examples/misc/makefile prebuilt/makefile prebuilt/macosx/makefile prebuilt/macosx/build-phase2 prebuilt/windows/makefile prebuilt/windows/build-phase2" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure @@ -25420,6 +25437,8 @@ do "gsi/makefile") CONFIG_FILES="$CONFIG_FILES gsi/makefile" ;; "gsc/makefile") CONFIG_FILES="$CONFIG_FILES gsc/makefile" ;; "bin/makefile") CONFIG_FILES="$CONFIG_FILES bin/makefile" ;; + "bin/gambc-doc.bat.unix") CONFIG_FILES="$CONFIG_FILES bin/gambc-doc.bat.unix" ;; + "bin/gambc-doc.bat.windows") CONFIG_FILES="$CONFIG_FILES bin/gambc-doc.bat.windows" ;; "misc/makefile") CONFIG_FILES="$CONFIG_FILES misc/makefile" ;; "doc/makefile") CONFIG_FILES="$CONFIG_FILES doc/makefile" ;; "tests/makefile") CONFIG_FILES="$CONFIG_FILES tests/makefile" ;; diff --git a/configure.ac b/configure.ac index 0aeca1be0..bb4d9c6a0 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ # Configure template for Gambit-C system. -# Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved. +# Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. # Process this file with autoconf to produce a configure script. @@ -17,7 +17,7 @@ AC_SUBST(PACKAGE_STRING) AC_SUBST(PACKAGE_BUGREPORT) AC_SUBST(PACKAGE_TARNAME) -AC_COPYRIGHT([[Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved.]]) +AC_COPYRIGHT([[Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.]]) AC_CONFIG_SRCDIR(include/gambit.h.in) @@ -381,6 +381,16 @@ if test "$ENABLE_SHARED" != "yes"; then ENABLE_ABSOLUTE_SHARED_LIBS=no fi +############################################################################### +# +# Determine which browser to use for help. + +AC_ARG_ENABLE(help-browser, + AC_HELP_STRING([--enable-help-browser=BROWSER], + [Browser to use for help (default is to search)]), + HELP_BROWSER=$enableval, + HELP_BROWSER="") + ############################################################################### # # Check for C compiler. @@ -1532,10 +1542,11 @@ AC_SUBST(ENABLE_SHARED) AC_SUBST(ENABLE_ABSOLUTE_SHARED_LIBS) AC_SUBST(ENABLE_VERSIONNED_LIBS) AC_SUBST(emacsdir) +AC_SUBST(HELP_BROWSER) AC_PROG_MAKE_SET -AC_OUTPUT(makefile include/makefile include/gambit.h lib/makefile lib/guide/guidepro lib/guide/makefile lib/guide/images/makefile gsi/makefile gsc/makefile bin/makefile misc/makefile doc/makefile tests/makefile examples/makefile examples/distr-comp/makefile examples/pi/makefile examples/ring/makefile examples/web-repl/makefile examples/web-server/makefile examples/tcltk/makefile examples/Xlib-simple/makefile examples/pthread/makefile examples/misc/makefile prebuilt/makefile prebuilt/macosx/makefile prebuilt/macosx/build-phase2 prebuilt/windows/makefile prebuilt/windows/build-phase2) +AC_OUTPUT(makefile include/makefile include/gambit.h lib/makefile lib/guide/guidepro lib/guide/makefile lib/guide/images/makefile gsi/makefile gsc/makefile bin/makefile bin/gambc-doc.bat.unix bin/gambc-doc.bat.windows misc/makefile doc/makefile tests/makefile examples/makefile examples/distr-comp/makefile examples/pi/makefile examples/ring/makefile examples/web-repl/makefile examples/web-server/makefile examples/tcltk/makefile examples/Xlib-simple/makefile examples/pthread/makefile examples/misc/makefile prebuilt/makefile prebuilt/macosx/makefile prebuilt/macosx/build-phase2 prebuilt/windows/makefile prebuilt/windows/build-phase2) if test "$ENABLE_SINGLE_HOST" != yes; then AC_MSG_NOTICE([ diff --git a/doc/gambit-c.txi b/doc/gambit-c.txi index 0ca81eb73..31f5883d7 100644 --- a/doc/gambit-c.txi +++ b/doc/gambit-c.txi @@ -267,7 +267,7 @@ compiler is invoked (this requires no special privileges). Synopsis: @example -@b{}gsi @r{[}-:@var{runtimeoption},@dots{}@r{]} @r{[}-i@r{]} @r{[}-f@r{]} @r{[}-v@r{]} @r{[}@r{[}-@r{]} @r{[}-e @var{expressions}@r{]} @r{[}@var{file}@r{]}@r{]}@dots{} +@b{}gsi @r{[}-:@r{@var{runtimeoption}},@dots{}@r{]} @r{[}-i@r{]} @r{[}-f@r{]} @r{[}-v@r{]} @r{[}@r{[}-@r{]} @r{[}-e @r{@var{expressions}}@r{]} @r{[}@r{@var{file}}@r{]}@r{]}@dots{} @end example @pindex gsi @@ -701,15 +701,15 @@ $ @b{gsi square 30 @r{@i{# will load square.o1}}} Synopsis: @example -@b{}gsc @r{[}-:@var{runtimeoption},@dots{}@r{]} @r{[}-i@r{]} @r{[}-f@r{]} @r{[}-v@r{]} - @r{[}-prelude @var{expressions}@r{]} @r{[}-postlude @var{expressions}@r{]} - @r{[}-dynamic@r{]} @r{[}-cc-options @var{options}@r{]} - @r{[}-ld-options-prelude @var{options}@r{]} @r{[}-ld-options @var{options}@r{]} +@b{}gsc @r{[}-:@r{@var{runtimeoption}},@dots{}@r{]} @r{[}-i@r{]} @r{[}-f@r{]} @r{[}-v@r{]} + @r{[}-prelude @r{@var{expressions}}@r{]} @r{[}-postlude @r{@var{expressions}}@r{]} + @r{[}-dynamic@r{]} @r{[}-cc-options @r{@var{options}}@r{]} + @r{[}-ld-options-prelude @r{@var{options}}@r{]} @r{[}-ld-options @r{@var{options}}@r{]} @r{[}-warnings@r{]} @r{[}-verbose@r{]} @r{[}-report@r{]} @r{[}-expansion@r{]} @r{[}-gvm@r{]} @r{[}-debug@r{]} @r{[}-debug-location@r{]} @r{[}-debug-source@r{]} @r{[}-debug-environments@r{]} @r{[}-track-scheme@r{]} - @r{[}-o @var{output}@r{]} @r{[}-c@r{]} @r{[}-keep-c@r{]} @r{[}-link@r{]} @r{[}-flat@r{]} @r{[}-l @var{base}@r{]} - @r{[}@r{[}-@r{]} @r{[}-e @var{expressions}@r{]} @r{[}@var{file}@r{]}@r{]}@dots{} + @r{[}-o @r{@var{output}}@r{]} @r{[}-c@r{]} @r{[}-keep-c@r{]} @r{[}-link@r{]} @r{[}-flat@r{]} @r{[}-l @r{@var{base}}@r{]} + @r{[}@r{[}-@r{]} @r{[}-e @r{@var{expressions}}@r{]} @r{[}@r{@var{file}}@r{]}@r{]}@dots{} @end example @menu @@ -786,8 +786,8 @@ Force interpreter mode. @item -f Do not examine the initialization file. @item -v -Print the system version string and time stamp on standard output and -exit. +Print the system version string, system time stamp and operating +system type on standard output and exit. @item -prelude @var{expressions} Add expressions to the top of the source code being compiled. @item -postlude @var{expressions} @@ -1885,6 +1885,20 @@ In addition to expressions, the REPL accepts the following special @cmindex ,? Give a summary of the REPL commands. +@item ,(h @var{subject}) +@cmindex ,(h @var{subject}) +This command will show the section of the Gambit manual with the +definition of the procedure or special form @var{subject}, which must +be a symbol. For example @samp{,(h time)} will show the section +documenting the @code{time} special form. Please see the @code{help} +procedure for additional information. + +@item ,h +@cmindex ,h +This command will show the section of the Gambit manual with the +definition of the procedure which raised the exception for which this +REPL was started. + @item ,q @cmindex ,q Terminate the process with exit status 0. This is equivalent to @@ -2167,6 +2181,46 @@ lst = '(5 2 hello 9 1) @node Procedures related to debugging, Console line-editing, Debugging example, Debugging @section Procedures related to debugging +@deffn procedure help @var{subject} +@deffnx procedure help-browser @r{[}@var{new-value}@r{]} + +The @code{help} procedure displays the section of the Gambit manual +with the definition of the procedure or special form @var{subject}, +which must be a procedure or symbol. For example the call @code{(help +gensym)} will show the section documenting the @code{gensym} procedure +and the call @code{(help 'time)} will show the section documenting the +@code{time} special form. The @code{help} procedure returns the void +object. + +The parameter object @code{help-browser} is bound to a string naming +the external program that is used by the @code{help} procedure to view +the documentation. Initially it is bound to the empty string. In +normal circumstances when @code{help-browser} is bound to an empty +string the @code{help} procedure runs the script +@code{~~bin/gambc-doc.bat} which searches for a suitable web browser +to open the documentation in HTML format. Unless the system was built +with the command @samp{configure --enable-help-browser=...}, the +text-only browser @samp{lynx} (see @uref{http://lynx.isc.org/}) will +be used by default if it is available. We highly recommend that you +install this browser if you are interested in viewing the +documentation within the console in which the REPL is running. You +can exit @samp{lynx} conveniently by typing an end of file (usually +@key{^D}). + +For example: + +@smallexample +> @b{(help-browser "firefox")} @r{@i{; use firefox instead of lynx}} +> @b{(help 'gensym)} +> @b{(help gensym)} @r{@i{; OK because gensym is a procedure}} +> @b{(help 'time)} +> @b{(help time)} @r{@i{; not OK because time is a special form}} +*** ERROR IN (console)@@5.7 -- Macro name can't be used as a variable: time +> +@end smallexample + +@end deffn + @deffn procedure repl-result-history-ref @var{i} @deffnx procedure repl-result-history-max-length-set! @var{n} diff --git a/doc/texi2html b/doc/texi2html index ce4ada47c..b25119271 100755 --- a/doc/texi2html +++ b/doc/texi2html @@ -6182,7 +6182,8 @@ sub t2h_default_def_item($$) } else { - return '' . $text . ''; +# return '' . $text . ''; ###GAMBIT### + return $text; } } return ''; @@ -6247,7 +6248,8 @@ sub t2h_default_def($) } else { - return "\n" . $text . "
\n"; +# return "\n" . $text . "
\n"; ###GAMBIT### move table to each definition + return $text . "\n"; } } return ''; @@ -7557,8 +7559,11 @@ sub t2h_default_def_line($$$$$$$$$$$$$$$$) # $type_name .= ' ' . $name . '' if ($name ne ''); ###GAMBIT### removed ###GAMBIT### added the following code to assign an anchor to each definition - my $anchor1_name = escape_url(escape_spaces('Definition of ' . $name)); - my $anchor2_name = escape_url(escape_spaces(ucfirst($category) . ' ' . $name)); + my $name2 = $name; + $name2 =~ s/<//g; + my $anchor1_name = escape_url(escape_spaces('Definition of ' . $name2)); + my $anchor2_name = escape_url(escape_spaces(ucfirst($category) . ' ' . $name2)); my $anchor1 = ''; my $anchor2 = ''; my $labels = ''; @@ -7587,8 +7592,8 @@ sub t2h_default_def_line($$$$$$$$$$$$$$$$) # return "" . $type_name . ###GAMBIT### removed # "" . $category_prepared . $index_label . "\n"; ###GAMBIT### - return $labels . "" . $type_name . ###GAMBIT### added to move index label to front - "" . $category_prepared . "\n"; ###GAMBIT### + return $labels . "
" . $type_name . ###GAMBIT### added to move index label to front + "" . $category_prepared . "
\n"; ###GAMBIT### } } diff --git a/doc/texinfo.tex b/doc/texinfo.tex index 617c1da44..21e23862f 100644 --- a/doc/texinfo.tex +++ b/doc/texinfo.tex @@ -5314,7 +5314,7 @@ % distinguish it from the body text that may end up on the next line % just below it. \def\temp{#1}% - \setbox0=\hbox{\kern\deflastargmargin \ifx\temp\empty\else [\rm\temp]\fi} + \setbox0=\hbox{\kern\deflastargmargin \ifx\temp\empty\else \rm\temp\fi} % % Figure out line sizes for the paragraph shape. % The first line needs space for \box0; but if \rightskip is nonzero, @@ -5369,7 +5369,7 @@ % % On the other hand, if an argument has two dashes (for instance), we % want a way to get ttsl. Let's try @var for that. - \let\var=\ttslanted +% \let\var=\ttslanted #1% \sl\hyphenchar\font=45{\tt#2} } diff --git a/gsi/main.scm b/gsi/main.scm index d78722812..3ecb2657e 100644 --- a/gsi/main.scm +++ b/gsi/main.scm @@ -1,8 +1,8 @@ ;;;============================================================================ -;;; File: "main.scm", Time-stamp: <2008-12-17 22:17:30 feeley> +;;; File: "main.scm", Time-stamp: <2009-02-11 22:28:43 feeley> -;;; Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved. +;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. ;;;---------------------------------------------------------------------------- @@ -445,7 +445,9 @@ (begin (##write-string (##system-version-string) ##stdout-port) (##write-string " " ##stdout-port) - (##write (##list (##system-stamp)) ##stdout-port) + (##write (##system-stamp) ##stdout-port) + (##write-string " " ##stdout-port) + (##write-string ##os-system-type-string-saved ##stdout-port) (##newline ##stdout-port) (##exit)) (split-command-line diff --git a/include/stamp.h b/include/stamp.h index 8037cfa2f..863a8937d 100644 --- a/include/stamp.h +++ b/include/stamp.h @@ -2,5 +2,5 @@ * Time stamp of last source code repository commit. */ -#define ___STAMP_YMD 20090210 -#define ___STAMP_HMS 175847 +#define ___STAMP_YMD 20090212 +#define ___STAMP_HMS 41213 diff --git a/lib/_repl#.scm b/lib/_repl#.scm index c24f5436d..3bfde4508 100644 --- a/lib/_repl#.scm +++ b/lib/_repl#.scm @@ -1,6 +1,6 @@ ;;;============================================================================ -;;; File: "_repl#.scm", Time-stamp: <2009-01-29 14:51:38 feeley> +;;; File: "_repl#.scm", Time-stamp: <2009-02-11 21:28:56 feeley> ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. @@ -19,6 +19,7 @@ depth cont initial-cont + reason prev-level prev-depth ) diff --git a/lib/_repl.scm b/lib/_repl.scm index 578080b25..aabd8838d 100644 --- a/lib/_repl.scm +++ b/lib/_repl.scm @@ -1,6 +1,6 @@ ;;;============================================================================ -;;; File: "_repl.scm", Time-stamp: <2009-02-10 12:57:14 feeley> +;;; File: "_repl.scm", Time-stamp: <2009-02-11 21:47:31 feeley> ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. @@ -955,7 +955,8 @@ (define-prim (##cmd-? port) (##write-string -",? | ,h : Summary of comma commands +",? : Summary of comma commands +,h | ,(h X) : Help on procedure of last error or procedure/macro named X ,q : Terminate the process ,qt : Terminate the current thread ,t : Jump to toplevel REPL @@ -2253,14 +2254,14 @@ (macro-current-repl-context)))) (define-prim (##make-initial-repl-context) - (macro-make-repl-context -1 0 #f #f #f #f)) + (macro-make-repl-context -1 0 #f #f #f #f #f)) (define ##repl #f) (set! ##repl - (lambda (#!optional (write-reason #f)) + (lambda (#!optional (write-reason #f) (reason #f)) (##continuation-capture (lambda (cont) - (##repl-within cont write-reason))))) + (##repl-within cont write-reason reason))))) (define-prim (##repl-debug #!optional (write-reason #f) (no-result? #f)) (let* ((old-setting @@ -2331,7 +2332,7 @@ (##exit)) -(define-prim (##repl-within cont write-reason) +(define-prim (##repl-within cont write-reason reason) (define (with-clean-exception-handling repl-context thunk) (##with-exception-catcher @@ -2453,6 +2454,7 @@ (##fixnum.+ depth 1) next (macro-repl-context-initial-cont context) + (macro-repl-context-reason context) (macro-repl-context-prev-level context) context)) context))) @@ -2536,9 +2538,21 @@ (let* ((cmd-src (##cadr code)) (cmd (##source-code cmd-src))) (cond - ((or (##eq? cmd '?) (##eq? cmd 'h)) + ((##eq? cmd '?) (##repl-channel-display-multiline-message ##cmd-?) (continue)) + ((##eq? cmd 'h) + (let* ((reason + (macro-repl-context-reason repl-context)) + (proc-and-args + (and reason + (##exception-procedure-and-arguments reason))) + (proc + (and proc-and-args + (##car proc-and-args)))) + (if proc + (##help proc))) + (continue)) ((##eq? cmd '-) (goto-depth (##fixnum.- (macro-repl-context-depth repl-context) 1))) @@ -2616,6 +2630,9 @@ (let* ((cmd2-src (##car cmd)) (cmd2 (##source-code cmd2-src))) (cond + ((##eq? cmd2 'h) + (##help (##source-code (##cadr cmd))) + (continue)) ((or (##eq? cmd2 'c) (##eq? cmd2 's) (##eq? cmd2 'l)) @@ -2658,7 +2675,7 @@ (let ((cont (first-interesting proc-or-cont))) - (##repl-within cont #f)) + (##repl-within cont #f #f)) (let ((proc proc-or-cont)) (##repl-within-proc @@ -2772,6 +2789,7 @@ 0 cont cont + reason prev-repl-context #f))) @@ -2800,7 +2818,7 @@ (##continuation-graft cont2 (lambda () - (##repl-within cont3 #f)))))) + (##repl-within cont3 #f #f)))))) (##continuation-graft cont @@ -2857,7 +2875,8 @@ (##display-exception-in-context exc first output-port) (if quit? (##exit-with-exception exc) - #f))))))))) + #f))))) + exc)))) (define-prim (##default-user-interrupt-handler) (let* ((settings (##set-debug-settings! 0 0)) @@ -2975,9 +2994,13 @@ (define max-displayed-args 15) - (define (display-call proc args) - (if proc - (display-call* proc args))) + (define (display-call) + (let* ((proc-and-args + (##exception-procedure-and-arguments exc)) + (proc + (and proc-and-args (##car proc-and-args)))) + (if proc + (display-call* proc (##cdr proc-and-args))))) (define (display-call* proc args) (let* ((call @@ -3042,9 +3065,7 @@ (macro-sfun-conversion-exception-code exc))) port) (##newline port) - (display-call - (macro-sfun-conversion-exception-procedure exc) - (macro-sfun-conversion-exception-arguments exc))) + (display-call)) ((macro-cfun-conversion-exception? exc) (##write-string @@ -3053,9 +3074,7 @@ (macro-cfun-conversion-exception-code exc))) port) (##newline port) - (display-call - (macro-cfun-conversion-exception-procedure exc) - (macro-cfun-conversion-exception-arguments exc))) + (display-call)) ((macro-datum-parsing-exception? exc) (let ((x @@ -3074,16 +3093,12 @@ ((macro-divide-by-zero-exception? exc) (##write-string "Divide by zero" port) (##newline port) - (display-call - (macro-divide-by-zero-exception-procedure exc) - (macro-divide-by-zero-exception-arguments exc))) + (display-call)) ((macro-fixnum-overflow-exception? exc) (##write-string "FIXNUM overflow" port) (##newline port) - (display-call - (macro-fixnum-overflow-exception-procedure exc) - (macro-fixnum-overflow-exception-arguments exc))) + (display-call)) ((macro-error-exception? exc) (##display (macro-error-exception-message exc) port) @@ -3112,44 +3127,32 @@ ((macro-invalid-hash-number-exception? exc) (##write-string "Invalid hash number" port) (##newline port) - (display-call - (macro-invalid-hash-number-exception-procedure exc) - (macro-invalid-hash-number-exception-arguments exc))) + (display-call)) ((macro-unbound-table-key-exception? exc) (##write-string "Unbound table key" port) (##newline port) - (display-call - (macro-unbound-table-key-exception-procedure exc) - (macro-unbound-table-key-exception-arguments exc))) + (display-call)) ((macro-unbound-serial-number-exception? exc) (##write-string "Unbound serial number" port) (##newline port) - (display-call - (macro-unbound-serial-number-exception-procedure exc) - (macro-unbound-serial-number-exception-arguments exc))) + (display-call)) ((macro-unbound-os-environment-variable-exception? exc) (##write-string "Unbound OS environment variable" port) (##newline port) - (display-call - (macro-unbound-os-environment-variable-exception-procedure exc) - (macro-unbound-os-environment-variable-exception-arguments exc))) + (display-call)) ((macro-unterminated-process-exception? exc) (##write-string "Process not terminated" port) (##newline port) - (display-call - (macro-unterminated-process-exception-procedure exc) - (macro-unterminated-process-exception-arguments exc))) + (display-call)) ((macro-nonempty-input-port-character-buffer-exception? exc) (##write-string "Input port character buffer is not empty" port) (##newline port) - (display-call - (macro-nonempty-input-port-character-buffer-exception-procedure exc) - (macro-nonempty-input-port-character-buffer-exception-arguments exc))) + (display-call)) ((macro-expression-parsing-exception? exc) (let ((x @@ -3173,30 +3176,22 @@ (display-arg-num (macro-improper-length-list-exception-arg-num exc)) (##write-string "List is not of proper length" port) (##newline port) - (display-call - (macro-improper-length-list-exception-procedure exc) - (macro-improper-length-list-exception-arguments exc))) + (display-call)) ((macro-join-timeout-exception? exc) (##write-string "'thread-join!' timed out" port) (##newline port) - (display-call - (macro-join-timeout-exception-procedure exc) - (macro-join-timeout-exception-arguments exc))) + (display-call)) ((macro-mailbox-receive-timeout-exception? exc) (##write-string "mailbox receive timed out" port) (##newline port) - (display-call - (macro-mailbox-receive-timeout-exception-procedure exc) - (macro-mailbox-receive-timeout-exception-arguments exc))) + (display-call)) ((macro-rpc-remote-error-exception? exc) (##write-string "RPC failed; remote error message follows" port) (##newline port) - (display-call - (macro-rpc-remote-error-exception-procedure exc) - (macro-rpc-remote-error-exception-arguments exc)) + (display-call) (##write-string (macro-rpc-remote-error-exception-message exc) port)) ((macro-keyword-expected-exception? exc) @@ -3204,9 +3199,7 @@ "Keyword argument expected" port) (##newline port) - (display-call - (macro-keyword-expected-exception-procedure exc) - (macro-keyword-expected-exception-arguments exc))) + (display-call)) ((macro-multiple-c-return-exception? exc) (##write-string @@ -3223,19 +3216,14 @@ "Operator is not a PROCEDURE" port) (##newline port) - (display-call* - (##inverse-eval - (macro-nonprocedure-operator-exception-operator exc)) - (macro-nonprocedure-operator-exception-arguments exc))) + (display-call)) ((macro-number-of-arguments-limit-exception? exc) (##write-string "Number of arguments exceeds implementation limit" port) (##newline port) - (display-call - (macro-number-of-arguments-limit-exception-procedure exc) - (macro-number-of-arguments-limit-exception-arguments exc))) + (display-call)) ((macro-os-exception? exc) (let ((message (macro-os-exception-message exc)) @@ -3245,24 +3233,18 @@ (if code (err-code->string code) "Unknown OS exception")) port)) (##newline port) - (display-call - (macro-os-exception-procedure exc) - (macro-os-exception-arguments exc))) + (display-call)) ((macro-no-such-file-or-directory-exception? exc) (##write-string "No such file or directory" port) (##newline port) - (display-call - (macro-no-such-file-or-directory-exception-procedure exc) - (macro-no-such-file-or-directory-exception-arguments exc))) + (display-call)) ((macro-range-exception? exc) (display-arg-num (macro-range-exception-arg-num exc)) (##write-string "Out of range" port) (##newline port) - (display-call - (macro-range-exception-procedure exc) - (macro-range-exception-arguments exc))) + (display-call)) ((macro-scheduler-exception? exc) (##write-string "Scheduler reported the exception: " port) @@ -3276,37 +3258,27 @@ ((macro-initialized-thread-exception? exc) (##write-string "Thread is initialized" port) (##newline port) - (display-call - (macro-initialized-thread-exception-procedure exc) - (macro-initialized-thread-exception-arguments exc))) + (display-call)) ((macro-uninitialized-thread-exception? exc) (##write-string "Thread is not initialized" port) (##newline port) - (display-call - (macro-uninitialized-thread-exception-procedure exc) - (macro-uninitialized-thread-exception-arguments exc))) + (display-call)) ((macro-inactive-thread-exception? exc) (##write-string "Thread is not active" port) (##newline port) - (display-call - (macro-inactive-thread-exception-procedure exc) - (macro-inactive-thread-exception-arguments exc))) + (display-call)) ((macro-started-thread-exception? exc) (##write-string "Thread is started" port) (##newline port) - (display-call - (macro-started-thread-exception-procedure exc) - (macro-started-thread-exception-arguments exc))) + (display-call)) ((macro-terminated-thread-exception? exc) (##write-string "Thread is terminated" port) (##newline port) - (display-call - (macro-terminated-thread-exception-procedure exc) - (macro-terminated-thread-exception-arguments exc))) + (display-call)) ((macro-type-exception? exc) (display-arg-num (macro-type-exception-arg-num exc)) @@ -3322,9 +3294,7 @@ (##write-string (if x (##cdr x) "Unknown type") port)))) (##write-string " expected" port) (##newline port) - (display-call - (macro-type-exception-procedure exc) - (macro-type-exception-arguments exc))) + (display-call)) ((macro-unbound-global-exception? exc) (##write-string "Unbound variable: " port) @@ -3335,27 +3305,21 @@ (##write-string "Uncaught exception: " port) (##write (macro-uncaught-exception-reason exc) port) (##newline port) - (display-call - (macro-uncaught-exception-procedure exc) - (macro-uncaught-exception-arguments exc))) + (display-call)) ((macro-unknown-keyword-argument-exception? exc) (##write-string "Unknown keyword argument passed to procedure" port) (##newline port) - (display-call - (macro-unknown-keyword-argument-exception-procedure exc) - (macro-unknown-keyword-argument-exception-arguments exc))) + (display-call)) ((macro-wrong-number-of-arguments-exception? exc) (##write-string "Wrong number of arguments passed to procedure" port) (##newline port) - (display-call - (macro-wrong-number-of-arguments-exception-procedure exc) - (macro-wrong-number-of-arguments-exception-arguments exc))) + (display-call)) (else (##write-string "This object was raised: " port) @@ -3364,6 +3328,150 @@ (display-exception exc)) +(define-prim (##exception-procedure-and-arguments exc) + (cond ((macro-sfun-conversion-exception? exc) + (##cons + (macro-sfun-conversion-exception-procedure exc) + (macro-sfun-conversion-exception-arguments exc))) + + ((macro-cfun-conversion-exception? exc) + (##cons + (macro-cfun-conversion-exception-procedure exc) + (macro-cfun-conversion-exception-arguments exc))) + + ((macro-divide-by-zero-exception? exc) + (##cons + (macro-divide-by-zero-exception-procedure exc) + (macro-divide-by-zero-exception-arguments exc))) + + ((macro-fixnum-overflow-exception? exc) + (##cons + (macro-fixnum-overflow-exception-procedure exc) + (macro-fixnum-overflow-exception-arguments exc))) + + ((macro-invalid-hash-number-exception? exc) + (##cons + (macro-invalid-hash-number-exception-procedure exc) + (macro-invalid-hash-number-exception-arguments exc))) + + ((macro-unbound-table-key-exception? exc) + (##cons + (macro-unbound-table-key-exception-procedure exc) + (macro-unbound-table-key-exception-arguments exc))) + + ((macro-unbound-serial-number-exception? exc) + (##cons + (macro-unbound-serial-number-exception-procedure exc) + (macro-unbound-serial-number-exception-arguments exc))) + + ((macro-unbound-os-environment-variable-exception? exc) + (##cons + (macro-unbound-os-environment-variable-exception-procedure exc) + (macro-unbound-os-environment-variable-exception-arguments exc))) + + ((macro-unterminated-process-exception? exc) + (##cons + (macro-unterminated-process-exception-procedure exc) + (macro-unterminated-process-exception-arguments exc))) + + ((macro-nonempty-input-port-character-buffer-exception? exc) + (##cons + (macro-nonempty-input-port-character-buffer-exception-procedure exc) + (macro-nonempty-input-port-character-buffer-exception-arguments exc))) + + ((macro-improper-length-list-exception? exc) + (##cons + (macro-improper-length-list-exception-procedure exc) + (macro-improper-length-list-exception-arguments exc))) + + ((macro-join-timeout-exception? exc) + (##cons + (macro-join-timeout-exception-procedure exc) + (macro-join-timeout-exception-arguments exc))) + + ((macro-mailbox-receive-timeout-exception? exc) + (##cons + (macro-mailbox-receive-timeout-exception-procedure exc) + (macro-mailbox-receive-timeout-exception-arguments exc))) + + ((macro-rpc-remote-error-exception? exc) + (##cons + (macro-rpc-remote-error-exception-procedure exc) + (macro-rpc-remote-error-exception-arguments exc))) + + ((macro-keyword-expected-exception? exc) + (##cons + (macro-keyword-expected-exception-procedure exc) + (macro-keyword-expected-exception-arguments exc))) + + ((macro-number-of-arguments-limit-exception? exc) + (##cons + (macro-number-of-arguments-limit-exception-procedure exc) + (macro-number-of-arguments-limit-exception-arguments exc))) + + ((macro-os-exception? exc) + (##cons + (macro-os-exception-procedure exc) + (macro-os-exception-arguments exc))) + + ((macro-no-such-file-or-directory-exception? exc) + (##cons + (macro-no-such-file-or-directory-exception-procedure exc) + (macro-no-such-file-or-directory-exception-arguments exc))) + + ((macro-range-exception? exc) + (##cons + (macro-range-exception-procedure exc) + (macro-range-exception-arguments exc))) + + ((macro-initialized-thread-exception? exc) + (##cons + (macro-initialized-thread-exception-procedure exc) + (macro-initialized-thread-exception-arguments exc))) + + ((macro-uninitialized-thread-exception? exc) + (##cons + (macro-uninitialized-thread-exception-procedure exc) + (macro-uninitialized-thread-exception-arguments exc))) + + ((macro-inactive-thread-exception? exc) + (##cons + (macro-inactive-thread-exception-procedure exc) + (macro-inactive-thread-exception-arguments exc))) + + ((macro-started-thread-exception? exc) + (##cons + (macro-started-thread-exception-procedure exc) + (macro-started-thread-exception-arguments exc))) + + ((macro-terminated-thread-exception? exc) + (##cons + (macro-terminated-thread-exception-procedure exc) + (macro-terminated-thread-exception-arguments exc))) + + ((macro-type-exception? exc) + (##cons + (macro-type-exception-procedure exc) + (macro-type-exception-arguments exc))) + + ((macro-uncaught-exception? exc) + (##cons + (macro-uncaught-exception-procedure exc) + (macro-uncaught-exception-arguments exc))) + + ((macro-unknown-keyword-argument-exception? exc) + (##cons + (macro-unknown-keyword-argument-exception-procedure exc) + (macro-unknown-keyword-argument-exception-arguments exc))) + + ((macro-wrong-number-of-arguments-exception? exc) + (##cons + (macro-wrong-number-of-arguments-exception-procedure exc) + (macro-wrong-number-of-arguments-exception-arguments exc))) + + (else + #f))) + (define ##display-exception-hook #f) (set! ##display-exception-hook ##default-display-exception) @@ -3601,6 +3709,115 @@ ;;;---------------------------------------------------------------------------- +(define-prim (##gambc-doc . args) + + (define (gambc-doc args) + + (define (gen-args args i) + (if (##null? args) + '() + (##cons (arg (##string-append "ARG" (##number->string i 10)) + (##car args)) + (gen-args (##cdr args) (##fixnum.+ i 1))))) + + (define (arg name val) + (##string-append "GAMBC_DOC_" name "=" val)) + + (define (install-dir path) + (parameterize + ((##current-directory + (##path-expand path))) + (##current-directory))) + + (let* ((gambcdir-bin + (install-dir "~~bin")) + (gambcdir-doc + (install-dir "~~doc"))) + (##open-process + #t + (lambda (port) + (let ((status (##process-status port))) + (##close-port port) + status)) + open-process + (##list path: + (##string-append gambcdir-bin "gambc-doc.bat") + arguments: + '() + environment: + (##append + (let ((env (##os-environ))) + (if (##fixnum? env) '() env)) + (##cons (arg "GAMBCDIR_BIN" + (##path-strip-trailing-directory-separator + gambcdir-bin)) + (##cons (arg "GAMBCDIR_DOC" + (##path-strip-trailing-directory-separator + gambcdir-doc)) + (gen-args args 1)))) + stdin-redirection: #f + stdout-redirection: #f + stderr-redirection: #f)))) + + (let ((exit-status (gambc-doc args))) + (if (##fixnum.= exit-status 0) + (##void) + (##raise-error-exception + "failed to display the document" + args)))) + +(define-prim (##escape-link str) + (##apply ##string-append + (##map (lambda (c) + (cond ((##char=? c #\space) "_") + ((##char=? c #\#) "%E2%99%AF") + ((##char=? c #\%) "%25") + ((##char=? c #\*) "%2A") + ((##char=? c #\+) "%2B") + ((##char=? c #\<) "%3C") + ((##char=? c #\>) "%3E") + (else (##string c)))) + (##string->list str)))) + +(define-prim (##show-help prefix subject) + (##gambc-doc "help" + subject + (##help-browser) + (##escape-link (##string-append prefix subject)))) + +(define ##help-browser + (##make-parameter + "" + (lambda (val) + (macro-check-string val 1 (##help-browser val) + val)))) + +(define help-browser + ##help-browser) + +(define-prim (##show-definition-of subject) + (let ((s + (cond ((##procedure? subject) + (##object->string (##procedure-name subject))) + (else + (##object->string subject))))) + (##show-help "Definition of " s))) + +(define-prim (##default-help subject) + (##show-definition-of subject)) + +(define ##help-hook #f) +(set! ##help-hook ##default-help) + +(define-prim (##help subject) + (##help-hook subject)) + +(define-prim (help subject) + (macro-force-vars (subject) + (##help subject))) + +;;;---------------------------------------------------------------------------- + (define-runtime-macro (time expr) `(##time (lambda () ,expr) ',expr)) diff --git a/lib/gambit#.scm b/lib/gambit#.scm index 623682ea2..bd37240bc 100644 --- a/lib/gambit#.scm +++ b/lib/gambit#.scm @@ -1,6 +1,6 @@ ;;;============================================================================ -;;; File: "gambit#.scm", Time-stamp: <2009-01-29 15:02:37 feeley> +;;; File: "gambit#.scm", Time-stamp: <2009-02-11 11:14:10 feeley> ;;; Copyright (c) 2005-2009 by Marc Feeley, All Rights Reserved. @@ -280,6 +280,8 @@ group-info-members group-info-name group-info? heap-overflow-exception? +help +help-browser host-info host-info-addresses host-info-aliases