Commit of 3.99.2 version

CHANGES

@@ -1,3 +1,24 @@
+06/09/98 Release 3.99.2
+-----------------------
+
+This is mainly a bug correcting release
+Otherwise:
+	* Can be compiled on AIX
+
+	* a new script file "stk-genmake" file can be used to build a 
+	Makefile for extensions. It constructs a Makefile which uses 
+	exactly the same options and compiler that was used to
+ 	build the interpreter.
+
+	* New function: write* to write cirular structures (rad has been 
+	updated for reading such structures -- and format for writing them 
+	too)
+
+	* Better HTML support
+
+	* New STklos slot allocation scheme: :EACH-CLASS
+
+
 04/27/98 Release 3.99.1
 -----------------------
 

ChangeLog

@@ -1,3 +1,114 @@
+1998-06-09  Erick Gallesio  <eg@unice.fr>
+
+	* Release 3.99.2
+
+1998-06-03  Erick Gallesio  <eg@unice.fr>
+
+	* Src/port.c (STk_read_line): Iconcorrect behaviour when a file is
+ 	not ended by a newline (thanks to Shiro Kawai
+ 	<shiro@sqush.squareusa.com>)
+	
+1998-06-02  Erick Gallesio  <eg@unice.fr>
+
+	* Tcl/tcl.h: Added a dumb field to the Tcl_Obj type for AIX cc
+	compiler (thanks to Eric Fintzel <tpfintz@fr.ibm.com>)
+
+	* Src/dynload.c : Added fake functions STk_call_external,
+ 	STk_external_existsp and STk_cstring2string for systems without
+ 	dynamic loading. Patch proposed by Eric Fintzel <tpfintz@fr.ibm.com>
+	and Ron Lawrence <lawrence@chrysalis.com>.
+
+	* Extensions/stk-genmake.in: File added. This script file can be
+ 	used to build a Makefile for extensions. It constructs a Makefile
+ 	which uses exactly the same options and compiler that was used to
+ 	build the interpreter.
+
+	* Extensions/%README: Updated.
+
+1998-06-01  Erick Gallesio  <eg@unice.fr>
+
+	* STklos/Tk/Basics.stklos: Added exportations of <Tk-object> and
+ 	tk-constructor.
+
+	* STklos/Tk/Tk-meta.stklos: Added exportation of
+ 	compute-tk-virtual-get-n-set.
+
+1998-05-31  Erick Gallesio  <eg@unice.fr>
+
+	* STklos/stklos.stk (ensure-class): Better error message when a
+ 	slot or a metaclass is duplicated (the duplicate is now clearly shown
+	now).  
+
+	* configure.in: Added the -fpic option for Linux shared libraries.
+  	It seems that problems appear when the object file is bigger than
+ 	64Kb (at least the Tktable is is in this case).
+
+1998-05-30  Erick Gallesio  <eg@unice.fr>
+
+	* Doc/Reference/*.tex : Documentation update
+
+	* Src/port.c (internal_format): Added the ~W format
+
+	* Src/print.c: heavy rewritting. should be a little bit more
+ 	efficient.
+	
+1998-05-28  Erick Gallesio  <eg@unice.fr>
+
+	* Extensions/html.c (html_next_token): Partly rewritten to take
+ 	into account the syntax "&#number;" (signalled by Jacques
+ 	Chazarain).  BTW, the procedure has now the same behaviour as
+ 	Netscape for unfinished entity (e.g. x&zz<...> is seen as a string
+ 	which must not be interpretated).
+	
+
+1998-05-25  Erick Gallesio  <eg@unice.fr>
+
+	* Src/read.c: Now we can read circular data such as the ones
+	built by write*
+
+1998-05-22  Erick Gallesio  <eg@unice.fr>
+
+	* STklos/Tk/Tk-classes.stklos: Added <Tk-composite-toplevel> to
+	Tk-classes.
+
+1998-05-21  Erick Gallesio  <eg@unice.fr>
+
+	* Tk/unix/tkUnixSend.c (Tk_SetAppName): Change the names of
+ 	mutiple applications from "STk #2", "STk #3", ... to "STk#2",
+ 	"STk#3" to avoid problems with the (winfo 'interps) call.
+	This is clearly a hack.
+
+1998-05-19  Erick Gallesio  <eg@unice.fr>
+
+	* Extensions/process.c: Correction of a bug that prevents you from
+ 	getting the exit status of a child process under certain
+ 	circumstances. Patch provided by Grant Edwards
+ 	<grante@reddwarf.frco.com>
+
+	* Src/tcl-glue.c (STk_tcl_getvar): forgot a return in the function 
+	which breaks result at least on Solaris (thanks to Thomas Buerger
+	for the patch).
+
+	* STklos/stklos.stk (compute-get-n-set): Added the :each-subclass
+ 	allocation scheme which correspond to the 3.1.1 :class allocation.
+  	Change was requested by Thomas Buerger
+ 	<buerger@serv1.iaa.tu-clausthal.de>
+
+1998-05-15  Erick Gallesio  <eg@unice.fr>
+
+	* Lib/trace.stk: Bug correction: traces of primitives was incorrect.
+
+1998-05-14  Erick Gallesio  <eg@unice.fr>
+
+	* Lib/init.stk:
+	* Src/toplevel.c: New global variable *last-defined* which is set
+	when a define is done. This allow some traces when evaluating 
+	large pieces of code.
+
+1998-05-11  Erick Gallesio  <eg@unice.fr>
+
+	* Lib/tk-init.stk : functions of image.stk are now autoload
+
 1998-04-30  Erick Gallesio  <eg@unice.fr>
 
 	* STk-3.99.1 Release

Doc/Reference/Appendix-E.tex

@@ -3,7 +3,7 @@
 %
 %           Author: Erick Gallesio [eg@unice.fr]
 %    Creation date: 21-Dec-1997 20:09
-% Last file update: 18-Apr-1998 13:36
+% Last file update:  9-Jun-1998 09:33
 %
 
 \section*{Introduction}
@@ -16,6 +16,18 @@ recent versions of STk.  Differences with older versions as well as
 implementation changes are described in the CHANGES file located in
 the main directory of the STk distribution.
 
+
+\section*{Release 3.99.1}
+\small{\emph{Release date: 04/27/98}}
+Mainly a bugs correcting release.
+
+New function: \texttt{write*} which handle circular structures. \texttt{Format}
+accepts now the special tag ``\verb+~W+'' for circular structures writing.
+
+\section*{Release 3.99.1}
+\small{\emph{Release date: 04/27/98}}
+Mainly a bugs correcting release
+
 \section*{Release 3.99.0}
 \small{\emph{Release date: 04/10/98}}
 

Doc/Reference/Reference1.tex

@@ -3,7 +3,7 @@
 %
 %           Author: Erick Gallesio [eg@unice.fr]
 %    Creation date: ??-Nov-1993 ??:??
-% Last file update: 18-Apr-1998 14:47
+% Last file update: 30-May-1998 23:04
 %
 
 \section*{Introduction}
@@ -96,6 +96,28 @@ This kind of comment extends to the end of the line (as described in \rrrr).
     (let ((foo 2))
        \sharpsign.foo)                             \lev 1
   \end{scheme}
+
+\label{circlistnot}
+\item[\tt\sharpsign{\em n}=] is used to represent circular structures
+  \mainindex{circular structures}. The value given of \emph{n}miust be a
+  number. It is used as a label, which can be referenced later by a
+  {\tt \sharpsign{\em n}\sharpsign} syntax (see below). The scope of
+  the label is the expression being read by the outermost \ide{read}.
+  
+\item[\tt\sharpsign{\em n}=] is used to reference a some object
+  labeled by a {\tt \sharpsign{\em n}=} syntax; that is, 
+  {\tt \sharpsign{\em n}\sharpsign} represents a pointer to the object 
+  labeled exactly by {\tt \sharpsign{\em n}=}. For instance, the object
+  created returned by the following expression 
+  \begin{scheme}
+  (let* ((a (list 1 2))
+      (b (append '(x y) a)))
+  (list a b))
+  \end{scheme}
+  caen be represented in this way:
+  \begin{scheme}
+    \verb+(#0=(1 2) (x y . #0#))+
+  \end{scheme}
 \end{description}
 
 
@@ -1167,14 +1189,22 @@ output string \var{port}.
 
 \begin{entry}{%
 \proto{close-input-port}{ port}{procedure}
-\proto{close-output-port}{ port}{procedure}}
+a\proto{close-output-port}{ port}{procedure}}
 \saut
 \doc
 \end{entry}
 
 \begin{entry}{%
 \proto{read}{}{procedure}
-\proto{read}{ port}{procedure}
+\proto{read}{ port}{procedure}}
+\saut
+\mainindex{circular structures}
+The \stk{} procedure is identical to the \rrrr procedure. It has bee
+extended to accept the ``\verb+#x=+'' and ``\verb+#x#+'' notations
+used for circular stuctures (see \ref{circlistnot}).
+\end{entry}
+
+\begin{entry}{%
 \proto{read-char}{}{procedure}
 \proto{read-char}{ port}{procedure}
 \proto{peek-char}{}{procedure}
@@ -1199,7 +1229,40 @@ value returned by \ide{current-input-port}.
 
 \begin{entry}{%
 \proto{write}{ obj}{procedure}
-\proto{write}{ obj port}{procedure}
+\proto{write}{ obj port}{procedure}}
+\saut
+\doc
+\end{entry}
+
+\begin{entry}{%
+\proto{write*}{ obj}{procedure}
+\proto{write*}{ obj port}{procedure}}
+\saut
+\mainindex{circular structures}
+Writes a written representation of \var{obj} to the given port.  The
+main difference with the \ide{write} procedure is that \ide{write*}
+handles data structures with cycles. Circular structure written by 
+this procedure use the ``\verb+#x=+'' and ``\verb+#x#+'' notations 
+(see \ref{circlistnot}).
+
+As \ide{write}, the \var{port} argument can be omitted, defaulting to
+the value returned by \ide{current\--output\--port}, and the value
+returned by \ide{write*} is undefined.
+
+\begin{scheme}
+(let ((l (cons 1 2)))
+  (set-cdr! l l)
+  (write* l))  \ev \textit{writes} \verb+#0=(1 . #0#)+
+
+(let ((l1 '(1 2)) 
+      (l2 '(3 4)) 
+      (l3 '(5 6))) 
+  (append! l1 l2 l3)
+  (list l1 l2 l3)) \ev \textit{writes} \verb+((1 2 . #0=(3 4 . #1=(5 6))) #0# #1#)+
+\end{scheme}
+\end{entry}
+
+\begin{entry}{%
 \proto{display}{ obj}{procedure}
 \proto{display}{ obj port}{procedure}
 \proto{newline}{}{procedure}
@@ -1218,11 +1281,15 @@ Writes the \var{obj}s to the given \var{port}, according to the format
 string \var{string}.  \var{String} is written literally, except for
 the following sequences:
 %
+\mainindex{circular structures}
 \begin{itemize}
-\item \tilda{}a or \tilda{}A is replaced by the printed representation of the
+\item \tilda{}a or \tilda{}A is replaced by the printed representation
-next \var{obj}.
+  of the next \var{obj}.
 \item \tilda{}s or \tilda{}S is replaced by the ``slashified'' printed
-representation of the next \var{obj}.
+  representation of the next \var{obj}.
+\item \tilda{}w or \tilda{}W is replaced by the printed representation
+  of the next \var{obj} (circular structures are correctly handled and
+  printed using \ide{writes*}).
 \item \tilda{}\tilda{} is replaced by a single tilde.
 \item \tilda{}\% is replaced by a newline
 \end{itemize}

Doc/Reference/manual.tex

@@ -13,7 +13,7 @@
 %
 %           Author: Erick Gallesio [eg@unice.fr]
 %    Creation date: ??-Nov-1993 ??:??
-% Last file update: 20-Apr-1998 10:07
+% Last file update: 30-May-1998 22:49
 %
 
 \documentclass[11pt,a4paper]{book}
@@ -78,7 +78,7 @@ email: eg@unice.fr}
 \end{center}
 \vskip8cm
 \begin{flushright}
-April 1998
+June 1998
 \end{flushright}
 \newpage
 \thispagestyle{empty}

Doc/Tcl93/Tcl93.log

@@ -1,113 +0,0 @@
-This is TeX, Version 3.14159 (C version 6.1) (format=latex 97.3.23)  29 MAR 1997 18:30
-**\nonstopmode\input{Tcl93.tex}
-(Tcl93.tex (/usr/lib/texmf/texmf/tex/latex/base/latex209.def
-File: latex209.def 1996/05/21 v0.51 Standard LaTeX file
-
-Entering LaTeX 2.09 compatibility mode.
-\footheight=\dimen102
-\@maxsep=\dimen103
-\@dblmaxsep=\dimen104
-\@cla=\count79
-\@clb=\count80
-\mscount=\count81
-(/usr/lib/texmf/texmf/tex/latex/base/tracefnt.sty
-Package: tracefnt 1996/05/08 v3.0h Standard LaTeX package (font tracing)
-\tracingfonts=\count82
-LaTeX Info: Redefining \selectfont on input line 139.
-)
-\symbold=\mathgroup4
-\symsans=\mathgroup5
-\symtypewriter=\mathgroup6
-\symitalic=\mathgroup7
-\symsmallcaps=\mathgroup8
-\symslanted=\mathgroup9
-LaTeX Font Info:    Redeclaring math alphabet \mathbf on input line 307.
-LaTeX Font Info:    Redeclaring math alphabet \mathsf on input line 308.
-LaTeX Font Info:    Redeclaring math alphabet \mathtt on input line 309.
-LaTeX Font Info:    Redeclaring math alphabet \mathit on input line 315.
-LaTeX Info: Redefining \em on input line 325.
-
-(/usr/lib/texmf/texmf/tex/latex/base/latexsym.sty
-Package: latexsym 1995/11/28 v2.2c Standard LaTeX package (lasy symbols)
-\symlasy=\mathgroup10
-LaTeX Font Info:    Overwriting symbol font `lasy' in version `bold'
-(Font)                  U/lasy/m/n --> U/lasy/b/n on input line 86.
-)
-LaTeX Font Info:    Redeclaring math delimiter \lgroup on input line 389.
-LaTeX Font Info:    Redeclaring math delimiter \rgroup on input line 391.
-LaTeX Font Info:    Redeclaring math delimiter \bracevert on input line 393.
-
-(/usr/lib/texmf/texmf/tex/latex/config/latex209.cfg
-(/usr/lib/texmf/texmf/tex/latex/tools/rawfonts.sty
-Compatibility mode: package `' requested, but `rawfonts' provided.
-Package: rawfonts 1994/05/08 Low-level LaTeX 2.09 font compatibility
-
-(/usr/lib/texmf/texmf/tex/latex/tools/somedefs.sty
-Package: somedefs 1994/06/01 Toolkit for optional definitions
-)
-LaTeX Font Info:    Try loading font information for U+lasy on input line 36.
-
-(/usr/lib/texmf/texmf/tex/latex/base/Ulasy.fd
-File: Ulasy.fd 1995/11/28 v2.2cLaTeX symbol font definitions
-))))
-(/usr/lib/texmf/texmf/tex/latex/base/article.cls
-Document Class: article 1996/05/26 v1.3r Standard LaTeX document class
-(/usr/lib/texmf/texmf/tex/latex/base/size10.clo
-File: size10.clo 1996/05/26 v1.3r Standard LaTeX file (size option)
-)
-\c@part=\count83
-\c@section=\count84
-\c@subsection=\count85
-\c@subsubsection=\count86
-\c@paragraph=\count87
-\c@subparagraph=\count88
-\c@figure=\count89
-\c@table=\count90
-\abovecaptionskip=\skip41
-\belowcaptionskip=\skip42
-Compatibility mode: definition of \rm ignored.
-Compatibility mode: definition of \sf ignored.
-Compatibility mode: definition of \tt ignored.
-Compatibility mode: definition of \bf ignored.
-Compatibility mode: definition of \it ignored.
-Compatibility mode: definition of \sl ignored.
-Compatibility mode: definition of \sc ignored.
-LaTeX Info: Redefining \cal on input line 543.
-LaTeX Info: Redefining \mit on input line 544.
-\bibindent=\dimen105
-) (tcl.sty
-tcl.sty
-\p@perwidth=\skip43
-\p@perlength=\skip44
-\mainsize=\skip45
-\leftsidemargin=\skip46
-\leftsideshift=\skip47
-\rightsidemargin=\skip48
-\rightsideshift=\skip49
-\headsidemargin=\skip50
-\footsidemargin=\skip51
-)
-
-! LaTeX Error: File `psfig.tex' not found.
-
-Type X to quit or <RETURN> to proceed,
-or enter new name. (Default extension: tex)
-
-Enter file name: 
-! Emergency stop.
-<read *> 
-         
-l.10 \input{psfig}
-                  ^^M
-*** (cannot \read from terminal in nonstop modes)
-
- 
-Here is how much of TeX's memory you used:
- 513 strings out of 10915
- 5111 string characters out of 72392
- 46212 words of memory out of 262141
- 3400 multiletter control sequences out of 9500
- 18987 words of font info for 72 fonts, out of 150000 for 255
- 14 hyphenation exceptions out of 607
- 22i,0n,20p,334b,113s stack positions out of 300i,40n,60p,3000b,4000s
-No pages of output.

Extensions/%README

@@ -1,20 +1,22 @@
-Extensions directory
---------------------
 
-This file contains extensions of the core interpreter which can be dynamically
-loaded. See the file README in the release main directory to see the systems
-for which dynamic loading support exists.
 
-Two extensions are provided as exemples:
+			STk Extensions directory
+			------------------------
+
+
+This file contains extensions of the core interpreter which can be
+dynamically loaded. See the file README in the release main directory
+to see the systems for which dynamic loading support exists.
+
+Two extensions are provided as examples:
 
 	- stack.c: a (very simple) package providing the stack type to the 
 	  interpreter. This package is presented in the documentation
 	  about STk interpreter extension.
 	- when.c: an implementation of when and unless
 
-Other extensions ar more "useful":
+Other extensions are more "useful":
 
-	- stklos.c + gf.c: all that is necessary for STklos
 	- hash.c: a package for hash-table in Scheme (the one used by STklos)
 	- pixmap.c: an extension for adding the XPM (pixmap) format to Tk4.0
 	  This extension is due to:
@@ -24,12 +26,25 @@ Other extensions ar more "useful":
 		Aachen, Germany
 	- html.c: a little extensions useful for (fast) html management
 	- process.c: an extension which provide process access to STk
-	- posix.c: a set of POSIX.1 fucntions for STk. Must be completed
+	- posix.c: a set of POSIX.1 functions for STk. Must be completed
 	- socket.c: simple support (and hence limited) for sockets. It allows you
 	  to make simple clients and servers program using TCP/IP
 	- sregexp.c Regular expressions
 
 
-For more informations on extension building, read the document "Extending the
+For more informations on extension building, read the document
-STk Interpreter" provided with the package.
+"Extending the STk Interpreter" provided with the package.
 
+
+Automatic generation of Makefiles
+=================================
+
+The script stk-genmake which is available in this directory can be
+used to automatically build a Makefile for a set of extensions. The
+Makefile is generated on standard output. For example, type
+
+	$ stk-genmake stack when > Makefile.example
+
+To generate a makefile for the two small extensions provided with the
+package. The generated Makfile takes into account the specificities of
+your achitecture and is generated by configure. 

Extensions/Makefile.in

@@ -12,7 +12,7 @@
 #
 #           Author: Erick Gallesio [eg@kaolin.unice.fr]
 #    Creation date:  6-Mar-1994 15:49
-# Last file update: 30-Apr-1998 10:57
+# Last file update:  2-Jun-1998 17:44
 
 include ../config.make
 
@@ -32,6 +32,7 @@ CFLAGS= $(SH_CCFLAGS) $(STKCFLAGS) $(DFLGS) -DUSE_TK @DEFS@ \
 
 ##############################################################################
 all: $(EXTRA_OBJ)
+	chmod 0755 stk-genmake
 
 # Following lines are needed for weird make commands. Use Gnu make....
 hash.$(SH_SUFFIX): 	hash.o 
@@ -48,7 +49,10 @@ install:
 	if test "$(EXTRA_OBJ)" != "" ; then $(CP) $(EXTRA_OBJ) $(execdir); fi
 
 install.libs:
-
+	-if [ ! -d $(bindir) ] ; then mkdir -p $(bindir); fi
+	cp stk-genmake $(bindir)
+	chmod 0755 $(bindir)/stk-genmake
 
 clean:
-	@/bin/rm -f *.o *.$(SH_SUFFIX) core *~ Makefile config.status config.log
+	@/bin/rm -f *.o *.$(SH_SUFFIX) core *~ Makefile config.status \
+	config.log stk-genmake

Extensions/Makefile.sample

@@ -1,99 +0,0 @@
-# 
-# M a k e f i l e . s a m p l e		-- A Makefile prototype for compiling
-#					   extensions which are dynamically 
-#					   loaded
-# Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-# 
-#
-# Permission to use, copy, and/or distribute this software and its
-# documentation for any purpose and without fee is hereby granted, provided
-# that both the above copyright notice and this permission notice appear in
-# all copies and derived works.  Fees for distribution or use of this
-# software or derived works may only be charged with express written
-# permission of the copyright holder.  
-# This software is provided ``as is'' without express or implied warranty.
-#
-#           Author: Erick Gallesio [eg@kaolin.unice.fr]
-#    Creation date: 17-Mar-1995 10:20
-# Last file update: 17-Mar-1995 10:48
-
-
-#####
-##### Start of configuration section
-#####
-
-CC=gcc
-LIBMALLOC=
-INCLUDES = -I../Tk -I../Tcl -I../Src -I../Mp
-
-
-# Define the 4 next line if you are running SUNOS4
-# Use -pic if using acc and fpic if using gcc
-     SH_CCFLAGS=-fpic
-     SH_LDFLAGS=-assert pure-text -o
-     SH_LOADER=ld
-     SH_SUFFIX=so
-# Define the 4 next lines if you are running SUNOS5
-#     SH_CCFLAGS=-K pic
-#     SH_LDFLAGS=-G -z text -h
-#     SH_LOADER=ld
-#     SH_SUFFIX=so
-# Define the 4 next lines if you are running OSF1
-#     SH_CCFLAGS=-fpic
-#     SH_LDFLAGS=-shared -o
-#     SH_LOADER=ld
-#     SH_SUFFIX=so 
-# Define the 4 next lines if you are running NETBSD1)
-#     SH_CCFLAGS=-fpic
-#     SH_LDFLAGS=-Bshareable -o
-#     SH_LOADER=ld
-#     SH_SUFFIX=so
-# Define the 5 next lines if you are running HPUX
-#     SH_CCFLAGS=+Z
-#     SH_LDFLAGS=-b -o
-#     SH_LOADER=ld
-#     SH_SUFFIX=sl
-#     CFLAGS=$CFLAGS -Wl,-E
-# Define the 5 next lines if you are running FREEBSD
-#     SH_CCFLAGS=-pic
-#     SH_LDFLAGS=-Bshareable -o
-#     SH_LOADER=ld
-#     LIB_MALLOC=/usr/lib/libgnumalloc.a
-#     SH_SUFFIX=so
-# Define the 4 next lines if you are running IRIX5
-#     SH_CCFLAGS=-fpic
-#     SH_LDFLAGS=-shared -o
-#     SH_LOADER=$CC
-#     SH_SUFFIX=so 
-# Define the 4 next lines if you are running LINUX
-#     SH_CCFLAGS=
-#     SH_LDFLAGS=-r -o
-#     SH_LOADER=ld
-#     SH_SUFFIX=so      
-#
-
-####
-#### End of of configuration section
-####
-
-
-##############################################################################
-.SUFFIXES: .$(SH_SUFFIX) .o .c
-
-.c.$(SH_SUFFIX):
-	$(CC) $(CFLAGS) -c -o $*.o $*.c
-	$(SH_LOADER) $(SH_LDFLAGS) $*.$(SH_SUFFIX) $*.o
-	if test -f a.out  ;then mv a.out $*.$(SH_SUFFIX); fi
-.o.$(SH_SUFFIX): 
-	$(SH_LOADER) $(SH_LDFLAGS) $*.$(SH_SUFFIX) $<
-	if test -f a.out  ;then mv a.out $*.$(SH_SUFFIX); fi
-
-##############################################################################
-CFLAGS = $(SH_CCFLAGS) $(INCLUDES) 
-
-help:
-	@echo "To make a new xxx.$(SH_SUFFIX) file, just type"
-	@echo "	   make xxx.$(SH_SUFFIX)"
-
-clean:
-	@/bin/rm -f *.o *.$(SH_SUFFIX) core *~ 

Extensions/configure

@@ -756,7 +756,7 @@ done
 
 ac_given_srcdir=$srcdir
 
-trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+trap 'rm -fr `echo "Makefile stk-genmake" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
 EOF
 cat >> $CONFIG_STATUS <<EOF
 
@@ -792,7 +792,7 @@ CEOF
 EOF
 cat >> $CONFIG_STATUS <<EOF
 
-CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
+CONFIG_FILES=\${CONFIG_FILES-"Makefile stk-genmake"}
 EOF
 cat >> $CONFIG_STATUS <<\EOF
 for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then

Extensions/configure.in

@@ -7,4 +7,4 @@ AC_INIT(process.c)
 CC=${CC-gcc}
 AC_HAVE_HEADERS(unistd.h limits.h)
 AC_HAVE_FUNCS(sigaction)
-AC_OUTPUT(Makefile)
+AC_OUTPUT(Makefile stk-genmake)

Extensions/html.c

@@ -2,7 +2,7 @@
  *
  * h t m l . c			-- Html support for STk
  *
- * Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+ * Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  * 
  *
  * Permission to use, copy, and/or distribute this software and its
@@ -17,11 +17,14 @@
  *
  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  *    Creation date:  1-Sep-1995 23:10
- * Last file update: 11-Oct-1996 15:54
+ * Last file update: 28-May-1998 21:57
  */
 
 #include <ctype.h>
 #include "stk.h"
+
+#define MAXTOKEN	40
+
 struct char_type {
   char *name;
   unsigned char c;
@@ -77,95 +80,147 @@ static void skip_spaces(FILE *f)
       }
     }
 }
-    
+
-static PRIMITIVE STk_html_next_token(SCM iport)
+/* next_entity: Read an entity such as <A HREF=x.html> */
+static SCM next_entity(FILE *f) 
 {
-  /* Return next HTML token */
-  char ch, *t, token[256];
-  int c;
   Tcl_DString dStr1, dStr2;
+  int c;
+  char ch;
   SCM z;
-  FILE *f;
-
-  if (!INP(iport)) Err("%Html:next-token: bad port", iport);
-
-  f = PORT_FILE(iport);
-
-  if (Eof(f) || ((c = Getc(f)) == EOF)) return STk_eof_object;
 
   Tcl_DStringInit(&dStr1);   Tcl_DStringInit(&dStr2);
   
-  if (c == '<') {
+  skip_spaces(f);
+  while ((c = Getc(f)) != EOF && (c != '>') && (c != ' ') && (c != '\t')) {
+    ch = tolower(c);
+    Tcl_DStringAppend(&dStr1, &ch, 1);
+  } 
+  if (c == ' ' || c == '\t') {
+    /* Read the argument */
     skip_spaces(f);
-    while ((c = Getc(f)) != EOF && (c != '>') && (c != ' ') && (c != '\t')) {
+    while ((c = Getc(f)) != EOF && (c != '>')) {
-      ch = tolower(c);
+      ch = c;
-      Tcl_DStringAppend(&dStr1, &ch, 1);
+      Tcl_DStringAppend(&dStr2, &ch, 1);
-    } 
-    if (c == ' ' || c == '\t') {
-      /* Read the argument */
-      skip_spaces(f);
-      while ((c = Getc(f)) != EOF && (c != '>')) {
-	ch = c;
-	Tcl_DStringAppend(&dStr2, &ch, 1);
-      } 
     }
+  }
     
-    if (Tcl_DStringValue(&dStr1)[0] == '\0') 
+  if (Tcl_DStringValue(&dStr1)[0] == '\0') 
-      z = STk_makestring("<>");
+    z = STk_makestring("<>");
-    else 
+  else 
-      if (Tcl_DStringValue(&dStr1)[0]=='/' && Tcl_DStringValue(&dStr1)[1] == '\0')
+    if (Tcl_DStringValue(&dStr1)[0]=='/' && Tcl_DStringValue(&dStr1)[1] == '\0')
-	z = STk_makestring("</>"); 
+      z = STk_makestring("</>"); 
-      else
+    else
-	z = Cons(STk_makestring(Tcl_DStringValue(&dStr1)),
+      z = Cons(STk_makestring(Tcl_DStringValue(&dStr1)),
-		 STk_makestring(Tcl_DStringValue(&dStr2)));
+	       STk_makestring(Tcl_DStringValue(&dStr2)));
-  }
-  else {
-    if (c == '&') {
-      t = token;
-      while ((c = Getc(f)) != EOF && c != ';' && isalpha(c)) *t++ = c;
-      *t = 0;
-      
-      if (c != ';') Ungetc(c, f);
-      
-      /* Search the given token in the translation table */
-      {
-	int i;
-
-	for (i = 0; table[i].c; i++)
-	  if (strcmp(token, table[i].name) == 0) {
-	    Tcl_DStringAppend(&dStr1, &table[i].c, 1);
-	    break;
-	  }
-	if (!table[i].c)  /* Not found */ Tcl_DStringAppend(&dStr1, token, -1);
-      }
-    } 
-    else {
-      do {
-	if (c == '<' || c == '&') {
-	  Ungetc(c, f);
-	  break;
-	}
-	ch = c;
-	Tcl_DStringAppend(&dStr1, &ch, 1);
-      } 
-      while ((c = Getc(f)) != EOF);
-    }
-    z = STk_makestring(Tcl_DStringValue(&dStr1));
-  }
 
   Tcl_DStringFree(&dStr1); Tcl_DStringFree(&dStr2);
   return z;
 }
 
 
-static PRIMITIVE STk_html_clean_spaces(SCM str, SCM ignore_spaces)
+/* Read an entity such as &amp;  */
+static void next_character(Tcl_DString *dStr, FILE *f)  
+{
+  char *t, ch, token[MAXTOKEN];
+  int c, i;
+  
+  token[0] = '&';
+  if ((c=Getc(f)) == '#') {		/* Read a &#000; entity */
+    token[1] = '#';
+    t = token + 2;
+    
+    while ((c=Getc(f)) != EOF && isdigit(c) && t < &token[MAXTOKEN-1]) {
+      *t++ = c;
+    }
+    *t = '\0';
+    if (c != ';')
+      /* Unget the terminator character for next reading */
+      Ungetc(c, f);
+    ch = (char) atoi(token+2);
+    if (ch > 10) {
+      Tcl_DStringAppend(dStr, &ch, 1);
+      return;
+    }
+  }
+  else {				/* Read a &aaaaa; entity */
+    t = token + 1;
+    while (c != EOF && isalpha(c) && t < &token[MAXTOKEN-1]) {
+      *t++ = c;
+      c = Getc(f);
+    }
+    *t = '\0';
+    if (c != ';') 
+      /* Unget the terminator character for next reading */
+      Ungetc(c, f);
+    
+    /* Search the given token in the translation table */
+    for (i = 0; table[i].c; i++)
+      if (strcmp(token+1, table[i].name) == 0) {
+	Tcl_DStringAppend(dStr, &table[i].c, 1);
+	return;
+      }
+  }
+
+  /* If we are here, we have not found the item in table or the number was 
+   * ill formed => bad syntax. */
+  Tcl_DStringAppend(dStr, token, -1);
+  if (c == ';') Tcl_DStringAppend(dStr, ";", 1); /* as netscape */
+}
+
+
+static PRIMITIVE html_next_token(SCM iport)   /* Return next HTML token */
+{
+  int c;
+  FILE *f;
+
+  ENTER_PRIMITIVE("%html:next-token");
+
+  if (!INP(iport)) Serror("bad port", iport);
+
+  f = PORT_FILE(iport);
+
+  if (Eof(f) || ((c = Getc(f)) == EOF)) return STk_eof_object;
+
+  if (c == '<') 
+    return next_entity(f);
+  else {
+    SCM z;
+    Tcl_DString dStr;
+    char ch;
+
+    Tcl_DStringInit(&dStr);
+    do {
+      if (c == '<') { 
+	Ungetc(c, f); 
+	break; 
+      }
+      else {
+	if (c == '&') 
+	  next_character(&dStr, f);
+	else {
+	  ch = c;
+	  Tcl_DStringAppend(&dStr, &ch, 1);
+	}
+      }
+    }
+    while ((c = Getc(f)) != EOF);
+    z = STk_makestring(Tcl_DStringValue(&dStr));
+    return z;
+  }
+}
+
+
+static PRIMITIVE html_clean_spaces(SCM str, SCM ignore_spaces)
 {
   Tcl_DString dString;
   char c, *s;
   int only_spaces = TRUE;
   SCM z;
-  
+
-  if (!STRINGP(str)) Err("%html:clean-spaces: bad string", str);
+  ENTER_PRIMITIVE("%html:clean-spaces");
+
+  if (!STRINGP(str)) Serror("bad string", str);
 
   Tcl_DStringInit(&dString);
   for (s = CHARS(str); c = *s; s++) {
@@ -190,7 +245,7 @@ static PRIMITIVE STk_html_clean_spaces(SCM str, SCM ignore_spaces)
 
 PRIMITIVE STk_init_html(void)
 {
-  STk_add_new_primitive("%html:clean-spaces",  tc_subr_2,  STk_html_clean_spaces);
+  STk_add_new_primitive("%html:clean-spaces",  tc_subr_2,  html_clean_spaces);
-  STk_add_new_primitive("%html:next-token",    tc_subr_1,  STk_html_next_token);
+  STk_add_new_primitive("%html:next-token",    tc_subr_1,  html_next_token);
   return UNDEFINED;
 }

Extensions/process.c

@@ -89,15 +89,21 @@ static int internal_process_alivep(SCM process)
   else {
     /* Use waitpid to gain the info. */
     res = waitpid(PROCPID(process), &info, WNOHANG);
-    if (res == 0) 
+    if (res == 0)
       /* process is still running */
       return TRUE;
-    else {
+    else 
-      /* process has terminated and we must save this information */
+      if (res == PROCPID(process)) {
-      PROCESS(process)->exited      = TRUE;
+	/* process has terminated and we must save this information */
-      PROCESS(process)->exit_status = info;
+	PROCESS(process)->exited      = TRUE;
-      return FALSE;
+	PROCESS(process)->exit_status = info;
-    }
+	return FALSE;
+      }
+      else {
+	/* might not have found process because we've already waited for it */
+	/* if so, then status has already been updated */
+	return FALSE;
+      }
   }
 }
 
@@ -176,7 +182,7 @@ static void cannot_run(int pipes[3][2], char **argv, char *msg, SCM obj)
     if (pipes[i][1] != -1) close(pipes[i][1]);
   }
   free(argv);
-  Err(msg, obj);
+  STk_procedure_error("run-process", msg, obj);
 }
 
 
@@ -205,15 +211,14 @@ static PRIMITIVE run_process(SCM l, int len)
       int i = -1;
 
       if (NCONSP(CDR(l))) 
-	cannot_run(pipes, argv_start,"run-process: no argument after keyword", tmp);
+	cannot_run(pipes, argv_start,"no argument after keyword", tmp);
       
       l = CDR(l); /* Go to next item */
       
       if (STk_eqv(tmp, STk_makekey(key_hst)) == Truth) {
 	/* :host keyword processing */
 	if (NSTRINGP(CAR(l)))
-	  cannot_run(pipes, argv_start, 
+	  cannot_run(pipes, argv_start, "string expected. It was", CAR(l));
-		     "run-process: string expected. It was", CAR(l));
 	strcpy(host, CHARS(CAR(l))); /* to avoid GC problems */
 	/* Shift argv to point the start of allocated zone. This avoid a copy
 	 * of arguments already processed.
@@ -227,8 +232,7 @@ static PRIMITIVE run_process(SCM l, int len)
 	if (STk_eqv(tmp, STk_makekey(key_wit)) == Truth) {
 	  /* :wait option processing */
 	  if (NBOOLEANP(CAR(l))) 
-	    cannot_run(pipes, argv_start,
+	    cannot_run(pipes, argv_start, "boolean expected. It was", CAR(l));
-		       "run-process: boolean expected. It was", CAR(l));
 	  
 	  waiting = (CAR(l) == Truth);
 	}
@@ -238,7 +242,7 @@ static PRIMITIVE run_process(SCM l, int len)
 	  if (STk_eqv(tmp, STk_makekey(key_out)) == Truth) i = 1; else
 	  if (STk_eqv(tmp, STk_makekey(key_err)) == Truth) i = 2;
 	  
-	  if (i < 0) cannot_run(pipes, argv_start, "run-process: bad keyword", tmp);
+	  if (i < 0) cannot_run(pipes, argv_start, "bad keyword", tmp);
 	  redirection[i] = CAR(l);
 	  
 	  if (STRINGP(redirection[i])) {
@@ -263,7 +267,7 @@ static PRIMITIVE run_process(SCM l, int len)
 		if (stat_i.st_dev==stat_j.st_dev && stat_i.st_ino==stat_j.st_ino) {
 		  /* Same file was cited 2 times */
 		  if (i == 0 || j == 0) {
-		    sprintf(msg, "run-process: read/write on the same file: %s",
+		    sprintf(msg, "read/write on the same file: %s", 
 			         CHARS(redirection[i]));
 		    cannot_run(pipes, argv_start, msg, NIL);
 		  }
@@ -287,7 +291,7 @@ static PRIMITIVE run_process(SCM l, int len)
 	    }
 	    
 	    if(pipes[i][0] < 0) {
-	      sprintf(msg, "run-process: can't redirect standard %s to file %s",
+	      sprintf(msg, "can't redirect standard %s to file %s",
 		      stdStreams[i], CHARS(redirection[i]));
 	      cannot_run(pipes, argv_start, msg, NIL);
 	    }
@@ -296,7 +300,7 @@ static PRIMITIVE run_process(SCM l, int len)
 	    if (KEYWORDP(redirection[i])) {
 	      /* Redirection in a pipe */
 	      if (pipe(pipes[i]) < 0) {
-		sprintf(msg, "run-process: can't create stream for standard %s",
+		sprintf(msg, "can't create stream for standard %s",
 			stdStreams[i]);
 		cannot_run(pipes, argv_start, msg, NIL);
 	      }
@@ -307,13 +311,13 @@ static PRIMITIVE run_process(SCM l, int len)
     else {
       /* Normal arg. Put it in argv */
       if (NSTRINGP(tmp)) 
-	cannot_run(pipes, argv_start, "run-process: bad string", tmp);
+	cannot_run(pipes, argv_start, "bad string", tmp);
       argv[argc++] = CHARS(tmp);
     }
   }
   argv[argc] = NULL;
-  
+
-  if (argc == 0) cannot_run(pipes, argv_start,"run-process: no command given", NIL);
+  if (argc == 0) cannot_run(pipes, argv_start,"no command given", NIL);
 
   /* Build a process object */
   proc = make_process();
@@ -321,7 +325,7 @@ static PRIMITIVE run_process(SCM l, int len)
   
   /* Fork another process */
   switch (pid = fork()) {
-    case -1: cannot_run(pipes,argv,"run-process: can't create child process", NIL);
+    case -1: cannot_run(pipes,argv,"can't create child process", NIL);
     case 0:  /* Child */
       	     for(i = 0; i < 3; i++) {
 	       if (STRINGP(redirection[i])) {
@@ -366,7 +370,7 @@ static PRIMITIVE run_process(SCM l, int len)
 
 		     f = (i == 0)? fdopen(pipes[i][1],"w"):fdopen(pipes[i][0],"r");
 		     if (f == NULL)
-		       cannot_run(pipes, argv, "run-process: cannot fdopen", proc);
+		       cannot_run(pipes, argv, "cannot fdopen", proc);
 
 		     sprintf(msg, "pipe-%s-%d", stdStreams[i], pid);
 
@@ -453,44 +457,57 @@ static PRIMITIVE process_wait(SCM process)
   
   if (PROCESS(process)->exited) return Ntruth;
   else {
-    int ret = waitpid(PROCPID(process), &PROCESS(process)->exit_status, 0);
+    int info, res;
-
+    
-    PROCESS(process)->exited = TRUE;
+    res = waitpid(PROCPID(process), &info, 0);
-    return (ret == 0) ? Ntruth : Truth;
+    
+    if (res == PROCPID(process)) {
+      PROCESS(process)->exit_status = info;
+      PROCESS(process)->exited = TRUE;
+      return Truth;
+    }
+    else
+      return Ntruth;
   }
 }
 
 
 static PRIMITIVE process_xstatus(SCM process)
 {
-  int info, n;
+  int info, n, res;
 
   PURGE_PROCESS_TABLE();
 
   if (NPROCESSP(process)) Err("process-exit-status: bad process", process);
   
-  if (PROCESS(process)->exited) n = PROCESS(process)->exit_status;
+  if (PROCESS(process)->exited)
+    n = WEXITSTATUS(PROCESS(process)->exit_status);
   else {
-    if (waitpid(PROCPID(process), &info, WNOHANG) == 0) {
+    res = waitpid(PROCPID(process), &info, WNOHANG);
+    if (res == 0) {
       /* Process is still running */
       return Ntruth;
     }
-    else {
+    else if (res == PROCPID(process)) {
       /* Process is now terminated */
       PROCESS(process)->exited      = TRUE;
       PROCESS(process)->exit_status = info;
       n = WEXITSTATUS(info);
     }
+    else
+      return Ntruth;
   }
   return STk_makeinteger((long) n);
 }
 
 static PRIMITIVE process_send_signal(SCM process, SCM signal)
 {
+  ENTER_PRIMITIVE("process-send-signal");
+
   PURGE_PROCESS_TABLE();
 
-  if (NPROCESSP(process)) Err("process-send-signal: bad process", process);
+  if (NPROCESSP(process)) Serror("bad process", process);
-  if (NINTEGERP(signal))  Err("process-send-signal: bad integer", signal);
+  if (NINTEGERP(signal))  Serror("bad integer", signal);
 
   kill(PROCPID(process), STk_integer_value(signal));
   return UNDEFINED;

Extensions/sregexp.c

@@ -57,10 +57,10 @@ static PRIMITIVE string_to_regexp (SCM obj)
   struct regexp *r;
   SCM z;
 
-  if (NSTRINGP (obj)) err ("not a string", obj);
+  ENTER_PRIMITIVE("string->regexp");
   
-  if ((r=TclRegComp(CHARS (obj))) == NULL)
+  if (NSTRINGP (obj)) 			     Serror("not a string", obj);
-    Err("string->regexp: error compiling regexp", obj);
+    if ((r=TclRegComp(CHARS (obj))) == NULL) Serror("error compiling regexp", obj);
   
   /* Regexp is Ok. Make a new cell and return it */
   NEWCELL(z, tc_regexp);
@@ -72,15 +72,17 @@ static PRIMITIVE string_to_regexp (SCM obj)
  * Try to match string against regular expression.  Returns sub-match
  * object, or #f if no match.
  */
-static PRIMITIVE apply_regexp(SCM regexp, SCM l, SCM env)
+static SCM apply_regexp(SCM regexp, SCM l, SCM env)
 {
   SCM string;
   char *the_chars;
 
-  if (STk_llength (l) != 1) err ("apply: bad number of args", l);
+  ENTER_SCM("apply-regexp");
+
+  if (STk_llength (l) != 1) Serror("bad number of args", l);
   string = CAR (l);
 
-  if (NSTRINGP (string)) err ("regexp: bad string", string);
+  if (NSTRINGP (string)) Serror("bad string", string);
   the_chars = CHARS (string);
   
   if (TclRegExec(REGEXP(regexp), the_chars, the_chars)) {

Extensions/stk-genmake.in

@@ -0,0 +1,80 @@
+#!/bin/sh
+:;exec snow -f "$0" "$@"				    # -*- Scheme -*-
+;;;;
+;;;;
+;;;; stk-genmake 		-- Generate a Makefile for STk extensions
+;;;;
+;;;; Copyright © 1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;; 
+;;;; Permission to use, copy, and/or distribute this software and its
+;;;; documentation for any purpose and without fee is hereby granted, provided
+;;;; that both the above copyright notice and this permission notice appear in
+;;;; all copies and derived works.  Fees for distribution or use of this
+;;;; software or derived works may only be charged with express written
+;;;; permission of the copyright holder.  
+;;;; This software is provided ``as is'' without express or implied warranty.
+;;;;
+;;;; $Id: stk-genmake.in 1.1 Sat, 06 Jun 1998 12:19:03 +0000 eg $
+;;;;
+;;;;           Author: Erick Gallesio [eg@unice.fr]
+;;;;    Creation date:  1-Jun-1998 18:44
+;;;; Last file update:  2-Jun-1998 17:51
+
+
+(define version "0.1")		
+(define config.make-file	; Complete path name of the  Config.make file 
+  (string-append (%library-location) "/" (machine-type) "/Config/config.make"))
+
+(define (abort . l)
+  (apply format (current-error-port) l)
+  (newline (current-error-port))
+  (exit 0))
+
+
+
+(define (generate-prelude targets)
+  (format #t "# Makefile automatically generated by ~A version ~A. DO NOT EDIT\n"   
+	  *program-name* version)
+  (if (file-exists? config.make-file)
+      ;; Copy the content of config.make
+      (with-input-from-file config.make-file
+	   (lambda ()
+	     (do ((l (read-line) (read-line)))
+		 ((eof-object? l) l)
+	       (format #t "~A\n" l))))
+      ;; config.make doesn't exists
+      (abort "~A: File ~S does not exist (you probably need a \"make install.libs\""
+	     *program-name*))
+
+  ;; Generate the .SUFFIXES rules
+  (format #t "CFLAGS= $(SH_CCFLAGS) $(STKCFLAGS) $(DFLGS) -DUSE_TK @DEFS@ \\\n")
+  (format #t  "-I$(incdir)\n\n\n")
+  (format #t ".SUFFIXES: .$(SH_SUFFIX) .o .c\n\n")
+  (format #t ".o.$(SH_SUFFIX):\n")
+  (format #t "\t$(SH_LOADER) $(SH_LDFLAGS) $*.$(SH_SUFFIX) $<\n")
+  (format #t "\tif test -f a.out  ;then mv a.out $*.$(SH_SUFFIX); fi\n\n")
+
+  ;; Generate the main target
+  (format #t "\nall:\t")
+  (for-each (lambda (x) (format #t "~A.$(SH_SUFFIX) " x)) targets)
+  (format #t "\n\n"))
+
+
+(define (generate-target target)
+  (format #t "\n~A.$(SH_SUFFIX): ~A.o\n\n" target target))
+
+(define (generate-postlude)
+  (format #t "clean:\n")
+  (format #t "\t@/bin/rm -f *.o *.$(SH_SUFFIX) core *~\n")
+  (format #t "#End of Makefile\n"))
+
+;;;;
+;;;; Program starts here
+;;;;
+
+(if (zero? *argc*)
+    (abort "Usage: ~A target [target ...]" *program-name*))
+
+(generate-prelude *argv*)
+(for-each generate-target *argv*)
+(generate-postlude)

INSTALL

@@ -135,13 +135,13 @@ can do a minimal test of stk with
 
 	$ (cd Src; /bin/sh test-stk)
 
-This will bring a little squared window on your screen (if your DISPLAY
+When you have the STk prompt (and if your DISPLAY variable is correctly set), 
-variable is correctly set). When this is done, enter the following  line
+just enter the following form:
 
 	(pack (button '.test :text "Hello, world" :command (lambda () (exit 0))))
 
-at the scheme prompt. This will display an Hello world button. Clicking on it 
+This will display an Hello world button. Clicking on it will leave the scheme
-will leave the scheme interpreter. A more complete demo can be obtained with:
+interpreter. A more complete demo can be obtained with:
 	
 	$ make demos
 

Lib/help.stk

@@ -13,11 +13,13 @@
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 14-Sep-1993 13:30
-;;;; Last file update:  2-Mar-1998 10:43
+;;;; Last file update: 28-May-1998 19:10
 ;;;;
 
 (require "www-browser")
 
+(select-module STk)
+
 (define (STk:show-help-file name)
   ;; Show the file (after having found the Help directory)
   (let loop ((l *help-path*))
@@ -27,7 +29,7 @@
 	       (fd (open-file f "r")))
 	  (catch (close-port fd))
 	  (if fd
-	      (STk:web-browser :url f)
+	      (www:browser :url f)
 	      (loop (cdr l)))))))
 
 (define (help . arg)
@@ -35,5 +37,5 @@
       (STk:show-help-file "STk-hlp.html")
       (STk:show-help-file (format #f "~A.n.html" (car arg))))
   #f)
-  
+
 (provide "help")

Lib/init.stk

@@ -11,11 +11,11 @@
 ;;;; permission of the copyright holder.  
 ;;;; This software is provided ``as is'' without express or implied warranty.
 ;;;;
-;;;; $Id: init.stk 1.14 Mon, 20 Apr 1998 20:15:01 +0000 eg $
+;;;; $Id: init.stk 1.15 Tue, 19 May 1998 10:44:58 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
 ;;;;    Creation date: ??-Sep-1993 ??:??
-;;;; Last file update: 20-Apr-1998 19:31
+;;;; Last file update: 14-May-1998 22:12
 ;;;;
 
 ;;;==============================================================================
@@ -560,9 +560,12 @@
 			 (else	  n)))
       (flush p)))
   
-  ;; Procedure called for printing toplevel evals
+  ;; Procedure called for printing toplevel results
   (define (repl-display-result result)
-    (unless (eqv? result (make-undefined))
+    (if (eqv? result (make-undefined))
-      (call-with-values (lambda () result)
+	(when *last-defined*
-			(lambda l 
+	  (format #t "~S\n" *last-defined*)
-			  (for-each (lambda (x) (write* x) (newline)) l))))))
+	  (set! *last-defined* #f))
+	(call-with-values (lambda () result)
+			  (lambda l
+			    (for-each (lambda (x) (write* x) (newline)) l))))))

Lib/tk-init.stk

@@ -17,11 +17,11 @@
 ;;;; This software is a derivative work of other copyrighted softwares; the
 ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; $Id: tk-init.stk 1.11 Fri, 10 Apr 1998 07:13:18 +0000 eg $
+;;;; $Id: tk-init.stk 1.13 Thu, 28 May 1998 20:07:43 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 17-May-1993 12:35
-;;;; Last file update: 28-Mar-1998 16:56
+;;;; Last file update: 28-May-1998 19:16
 ;;;;
 
 (unless (equal? *tk-version* "8.0")
@@ -322,12 +322,12 @@
 (autoload "focus" 	 Tk:focus-next Tk:focus-prev)
 (autoload "listener"  	 listener)
 (autoload "palette"   	 Tk:set-palette! Tk:bisque)
-(autoload "help"      	 help STk:show-help-file)
 (autoload "menu"      	 Tk:option-menu)
 (autoload "inspect-main" inspect view detail)
 (autoload "fileevent" 	 Tk:fileevent fileevent) ; for backward compatibility
 (autoload "sterm" 	 sterm)
-(autoload "www-browser"  WWW:browser)
+(autoload "image"        find-image make-image change-image delete-image)
+
 
 ;=============================================================================
 ;
@@ -337,7 +337,7 @@
 ; working with Tk. It is defined here, even if you don't use STklos
 ; (you really must use it :) so that it can be imported before Tk. So,
 ; if functions are redefined in STklos for Tk they will be seen before
-; the Tk ones. If the STklos is not used (it's a pity!), the module is
+; the Tk ones. If STklos is not used (it's a pity!), the module is
 ; just passed thru since it contains nothing.
 ;
 ;=============================================================================
@@ -352,7 +352,11 @@
   ;; autoload since C error function tests explicitely it is a closure before
   ;; applying its arguments
   (define (report-error . args)
-    (apply STk:report-error args)))
+    (apply STk:report-error args))
+  
+  ;; Global help functions which are defined when Tk is loaded
+  (autoload "help"         help STk:show-help-file)
+  (autoload "www-browser"  WWW:browser))
 
 ;;;;
 ;;;; Retain now that Tk is now fully initialized

Lib/trace.stk

@@ -11,11 +11,11 @@
 ;;;; permission of the copyright holder.  
 ;;;; This software is provided ``as is'' without express or implied warranty.
 ;;;;
-;;;; $Id: trace.stk 1.2 Sun, 18 Jan 1998 19:17:48 +0000 eg $
+;;;; $Id: trace.stk 1.3 Tue, 19 May 1998 10:44:58 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 26-Apr-1997 16:02
-;;;; Last file update: 18-Jan-1998 19:53
+;;;; Last file update: 15-May-1998 09:15
 
 
 (require "hash")
@@ -92,8 +92,8 @@
     ;; Trace symbol
     (let ((traced-proc  (cond  ; Order is important!!!
 			 ((generic?   proc)(trace-generic   symbol proc))
-			 ((procedure? proc)(trace-closure   symbol proc))
 			 ((primitive? proc)(trace-primitive symbol proc))
+			 ((procedure? proc)(trace-closure   symbol proc))
 			 (else		   (error "trace: cannot trace ~S" proc)))))
       (hash-table-put! *traced-symbols* symbol (cons traced-proc proc))
       traced-proc))

Lib/www-browser.stklos

@@ -13,7 +13,7 @@
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 21-Oct-1996 14:02
-;;;; Last file update: 16-Apr-1998 11:45
+;;;; Last file update: 28-May-1998 19:14
 ;;;;
 
 (require "Tk-classes")
@@ -137,7 +137,7 @@
     (unless browser
       (set! browser (make-interface 
 		       (or parent 
-			   (make <Toplevel> :title "Stk Web browser"))))
+			   (make <Toplevel> :title "STk Web browser"))))
       (bind browser "<Destroy>" (lambda () (set! browser #f))))
 
     (when url

Makefile.in

@@ -14,7 +14,7 @@
 #
 #           Author: Erick Gallesio [eg@unice.fr]
 #    Creation date: ??-Sep-1993 ??:??
-# Last file update: 27-Apr-1998 22:33
+# Last file update: 14-May-1998 11:28
 #
 
 
@@ -110,7 +110,7 @@ dvi:
 demos:
 	/bin/sh -c "(cd Demos; ../Src/test-stk -f S-scape README.html)"
 
-install: clean-before
+install: all clean-before
 	(cd Tcl;     	$(MAKE) install)
 	(cd Tk;      	$(MAKE) install)
 	(cd Mp;		$(MAKE) install)
@@ -185,7 +185,7 @@ clean-before:
 	    *) echo "No cleaning!";; \
 	  esac; \
 	fi
- 
+
 install.man:
 	(cd Doc;	$(MAKE) install.man)
 

STk.prj

@@ -1,11 +1,11 @@
 ;; -*- Lisp -*-
 (Created-By-Prcs-Version 1 2 1)
 (Project-Description "The STk Scheme Interpreter")
-(Project-Version STk 3.99.1 22)
+(Project-Version STk 3.99.2 7)
-(Parent-Version STk 3.99.1 21)
+(Parent-Version STk 3.99.2 6)
 (Version-Log "")
 (New-Version-Log "")
-(Checkin-Time "Thu, 30 Apr 1998 14:51:01 +0000")
+(Checkin-Time "Tue, 09 Jun 1998 07:40:04 +0000")
 (Checkin-Login eg)
 (Populate-Ignore ("\\.o$"
 		  "\\.a$"
@@ -34,16 +34,16 @@
 (Files
 
 ;; Top Level Files
-  (configure.in (STk/K/29_configure. 1.1.1.1 644))
+  (configure.in (STk/K/29_configure. 1.1.1.4 644))
-  (configure (STk/K/30_configure 1.1.1.1 755))
+  (configure (STk/K/30_configure 1.1.1.4 755))
-  (VERSION (STk/K/31_VERSION 1.3 644))
+  (VERSION (STk/K/31_VERSION 1.4 644))
   (README (STk/K/32_README 1.3 644))
-  (Makefile.in (STk/K/33_Makefile.i 1.3.1.5 644))
+  (Makefile.in (STk/K/33_Makefile.i 1.3.1.6 644))
-  (INSTALL (STk/K/35_INSTALL 1.3 644))
+  (INSTALL (STk/K/35_INSTALL 1.4 644))
-  (ChangeLog (STk/K/36_ChangeLog 1.20.1.5 644))
+  (ChangeLog (STk/K/36_ChangeLog 1.20.1.12 644))
   (COPYRIGHTS (STk/K/37_COPYRIGHTS 1.1 644))
   (COMPILING-HINTS (STk/K/38_COMPILING- 1.1 444))
-  (CHANGES (STk/K/39_CHANGES 1.6 644))
+  (CHANGES (STk/K/39_CHANGES 1.7 644))
   (BINARY_DISTRIB (STk/K/40_BINARY_DIS 1.2 644))
   
 ;; Contributions Directory
@@ -234,7 +234,7 @@
   (Demos/stklos-widgets.stklos (STk/M/49_stklos-wid 1.2 755))
   (Demos/term.stk (STk/M/50_term.stk 1.2 755))
   (Demos/tkcolor.stklos (STk/M/51_tkcolor.st 1.1 555))
-  (Demos/ttt.stk (STk/N/0_ttt.stk 1.1 555))
+  (Demos/ttt.stk (STk/N/0_ttt.stk 1.1 755))
   (Demos/turtle.stk (STk/N/1_turtle.stk 1.1 755))
   (Demos/S-scape.stklos (STk/d/b/5_S-scape.st 1.1 755))
   (Demos/widget.stk (STk/N/3_widget.stk 1.2 755))
@@ -262,8 +262,8 @@
   (Doc/FAQ/FAQ.html (STk/N/16_FAQ.html 1.1 444))
   (Doc/FAQ/FAQ.ps (STk/N/17_FAQ.ps 1.1 444))
   (Doc/FAQ/FAQ.txt (STk/N/18_FAQ.txt 1.1 444))
-  (Doc/Isotas96/Isotas96.dvi (STk/N/19_Isotas96.d 1.6 644) :no-keywords)
+  (Doc/Isotas96/Isotas96.dvi (STk/N/19_Isotas96.d 1.7 644) :no-keywords)
-  (Doc/Isotas96/Isotas96.ps (STk/N/20_Isotas96.p 1.6 644))
+  (Doc/Isotas96/Isotas96.ps (STk/N/20_Isotas96.p 1.7 644))
   (Doc/Isotas96/Isotas96.tex (STk/N/21_Isotas96.t 1.1 444))
   (Doc/Isotas96/Makefile (STk/N/22_Makefile 1.1 444))
   (Doc/Isotas96/bibliography.bib (../bibliography.bib) :symlink)
@@ -349,12 +349,12 @@
   (Doc/Reference/Appendix-B.tex (STk/O/45_Appendix-B 1.2 644))
   (Doc/Reference/Appendix-C.tex (STk/O/46_Appendix-C 1.2 644))
   (Doc/Reference/Appendix-D.tex (STk/O/47_Appendix-D 1.2 644))
-  (Doc/Reference/Appendix-E.tex (STk/O/48_Appendix-E 1.3 644))
+  (Doc/Reference/Appendix-E.tex (STk/O/48_Appendix-E 1.4 644))
   (Doc/Reference/Appendix-F.tex (STk/e/b/5_Appendix-F 1.1 644))
   (Doc/Reference/Detail.ps (STk/O/49_Detail.ps 1.1 444))
   (Doc/Reference/Inspector.ps (STk/O/50_Inspector. 1.1 444))
   (Doc/Reference/Makefile (STk/O/51_Makefile 1.2 644))
-  (Doc/Reference/Reference1.tex (STk/P/0_Reference1 1.2 644))
+  (Doc/Reference/Reference1.tex (STk/P/0_Reference1 1.3 644))
   (Doc/Reference/Reference2.tex (STk/P/1_Reference2 1.3 644))
   (Doc/Reference/Reference3.tex (STk/P/2_Reference3 1.2 644))
   (Doc/Reference/View.ps (STk/P/3_View.ps 1.1 444))
@@ -364,9 +364,9 @@
   (Doc/Reference/hierarchy.eps (STk/P/6_hierarchy. 1.1 444))
   (Doc/Reference/hierarchy.fig (STk/P/7_hierarchy. 1.1 444))
   (Doc/Reference/index.stk (STk/P/8_index.stk 1.1 444))
-  (Doc/Reference/manual.dvi (STk/P/9_manual.dvi 1.7 644) :no-keywords)
+  (Doc/Reference/manual.dvi (STk/P/9_manual.dvi 1.9 644) :no-keywords)
-  (Doc/Reference/manual.ps (STk/P/10_manual.ps 1.7 644) :no-keywords)
+  (Doc/Reference/manual.ps (STk/P/10_manual.ps 1.8 644) :no-keywords)
-  (Doc/Reference/manual.tex (STk/P/11_manual.tex 1.3 644))
+  (Doc/Reference/manual.tex (STk/P/11_manual.tex 1.4 644))
   (Doc/STklos+Tk/Basic-Fig-1.ps (STk/P/12_Basic-Fig- 1.1 444))
   (Doc/STklos+Tk/Chap1.tex (STk/P/13_Chap1.tex 1.1 444))
   (Doc/STklos+Tk/Chap2.tex (STk/P/14_Chap2.tex 1.1 440))
@@ -381,7 +381,6 @@
   (Doc/STklos+Tk/STklos+Tk.tex (STk/P/22_STklos+Tk. 1.1 444))
   (Doc/STklos+Tk/browser.stklos (STk/P/23_browser.st 1.1 444))
   (Doc/Tcl93/README (STk/P/24_README 1.1 444))
-  (Doc/Tcl93/Tcl93.log (STk/P/25_Tcl93.log 1.1 644))
   (Doc/Tcl93/Tcl93.ps (STk/P/26_Tcl93.ps 1.1 444))
   (Doc/Tcl93/Tcl93.tex (STk/P/27_Tcl93.tex 1.1 444))
   (Doc/Tcl93/bibliography.bib (../Reference/bibliography.bib) :symlink)
@@ -392,20 +391,20 @@
   (Doc/bibliography.bib (STk/e/b/6_bibliograp 1.1 644))
 
 ;; Modules Extensions Directory  
-  (Extensions/%README (STk/P/32_%README 1.1 444))
+  (Extensions/%README (STk/P/32_%README 1.2 644))
-  (Extensions/Makefile.in (STk/P/33_Makefile.i 1.2 644))
+  (Extensions/Makefile.in (STk/P/33_Makefile.i 1.3 644))
-  (Extensions/Makefile.sample (STk/P/34_Makefile.s 1.1 444))
+  (Extensions/configure (STk/P/35_configure 1.2 755))
-  (Extensions/configure (STk/P/35_configure 1.1 755))
+  (Extensions/configure.in (STk/P/36_configure. 1.2 644))
-  (Extensions/configure.in (STk/P/36_configure. 1.1 444))
   (Extensions/hash.c (STk/P/37_hash.c 1.1 644))
-  (Extensions/html.c (STk/P/38_html.c 1.1 444))
+  (Extensions/html.c (STk/P/38_html.c 1.2 644))
   (Extensions/jpeg.c (STk/P/39_jpeg.c 1.1 444))
   (Extensions/pixmap.c (STk/P/40_pixmap.c 1.1 444))
   (Extensions/posix.c (STk/P/41_posix.c 1.1 444))
-  (Extensions/process.c (STk/P/42_process.c 1.2 644))
+  (Extensions/process.c (STk/P/42_process.c 1.3 644))
   (Extensions/socket.c (STk/P/43_socket.c 1.2 644))
-  (Extensions/sregexp.c (STk/P/44_sregexp.c 1.1 444))
+  (Extensions/sregexp.c (STk/P/44_sregexp.c 1.2 644))
   (Extensions/stack.c (STk/P/45_stack.c 1.1 444))
+  (Extensions/stk-genmake.in (STk/e/b/28_stk-genmak 1.1 644))
   (Extensions/time.c (STk/P/46_time.c 1.1 444))
   (Extensions/when.c (STk/P/47_when.c 1.1 444))
 
@@ -574,10 +573,10 @@
   (Lib/focus.stk (STk/S/40_focus.stk 1.1 644))
   (Lib/ftp.stklos (STk/S/41_ftp.stklos 1.3 644))
   (Lib/hash.stk (STk/S/42_hash.stk 1.2 644))
-  (Lib/help.stk (STk/S/43_help.stk 1.2 644))
+  (Lib/help.stk (STk/S/43_help.stk 1.3 644))
   (Lib/html.stk (STk/S/44_html.stk 1.1 644))
   (Lib/image.stk (STk/S/45_image.stk 1.4 644))
-  (Lib/init.stk (STk/S/46_init.stk 1.14 644))
+  (Lib/init.stk (STk/S/46_init.stk 1.15 644))
   (Lib/inspect-detail.stk (STk/S/47_inspect-de 1.1 644))
   (Lib/inspect-help.stk (STk/S/48_inspect-he 1.1 444))
   (Lib/inspect-main.stk (STk/S/49_inspect-ma 1.2 644))
@@ -602,11 +601,11 @@
   (Lib/socket.stk (STk/T/16_socket.stk 1.1 444))
   (Lib/sterm.stk (STk/T/17_sterm.stk 1.3 644))
   (Lib/text.stk (STk/T/18_text.stk 1.3 644))
-  (Lib/tk-init.stk (STk/T/19_tk-init.st 1.11 644))
+  (Lib/tk-init.stk (STk/T/19_tk-init.st 1.13 644))
   (Lib/tk-unix.stk (STk/e/b/9_tk-unix.st 1.1 644))
-  (Lib/trace.stk (STk/T/20_trace.stk 1.2 644))
+  (Lib/trace.stk (STk/T/20_trace.stk 1.3 644))
   (Lib/unix.stk (STk/T/21_unix.stk 1.1 444))
-  (Lib/www-browser.stklos (STk/c/b/29_www-browse 1.3 644))
+  (Lib/www-browser.stklos (STk/c/b/29_www-browse 1.4 644))
   (Lib/www-file.stk (STk/T/23_www-file.s 1.2 644))
   (Lib/www-html.stk (STk/T/24_www-html.s 1.4 644))
   (Lib/www-http.stk (STk/T/25_www-http.s 1.2 644))
@@ -766,7 +765,7 @@
   (STklos/Makefile (STk/W/17_Makefile 1.4 644))
   (STklos/README.html (STk/W/18_README.htm 1.2 644))
   (STklos/Tk/%README (STk/W/19_%README 1.2 644))
-  (STklos/Tk/Basics.stklos (STk/W/20_Basics.stk 1.11 644))
+  (STklos/Tk/Basics.stklos (STk/W/20_Basics.stk 1.12 644))
   (STklos/Tk/Button.stklos (STk/W/21_Button.stk 1.4 644))
   (STklos/Tk/Canvas.stklos (STk/W/22_Canvas.stk 1.4 644))
   (STklos/Tk/Canvitem.stklos (STk/W/23_Canvitem.s 1.5 644))
@@ -800,14 +799,14 @@
   (STklos/Tk/Scrollbar.stklos (STk/W/44_Scrollbar. 1.2 644))
   (STklos/Tk/Text.stklos (STk/W/45_Text.stklo 1.5 644))
   (STklos/Tk/Tk-active.stklos (STk/W/46_Tk-active. 1.3 644))
-  (STklos/Tk/Tk-classes.stklos (STk/W/47_Tk-classes 1.12 644))
+  (STklos/Tk/Tk-classes.stklos (STk/W/47_Tk-classes 1.13 644))
-  (STklos/Tk/Tk-meta.stklos (STk/W/48_Tk-meta.st 1.8 644))
+  (STklos/Tk/Tk-meta.stklos (STk/W/48_Tk-meta.st 1.9 644))
   (STklos/Tk/Toplevel.stklos (STk/W/50_Toplevel.s 1.7 644))
 ; (STklos/Tk/Widget/ImgButton.stklos ())
   (STklos/active-slot.stklos (STk/c/b/21_active-slo 1.1 644))
   (STklos/composite-slot.stklos (STk/c/b/22_composite- 1.1 644))
   (STklos/describe.stklos (STk/c/b/14_describe.s 1.1 644))
-  (STklos/stklos.stk (STk/c/b/10_stklos.stk 1.21 644))
+  (STklos/stklos.stk (STk/c/b/10_stklos.stk 1.23 644))
   (STklos/trace-gf.stklos (STk/c/b/11_trace-gf.s 1.1 644))
   
 ;; Snow (Stk with NO Window) Directory
@@ -874,19 +873,19 @@
   (Snow/vector.c (../Src/vector.c) :symlink)
 
 ;; Source directory of the Interpreter
-  (Src/Makefile.in (STk/X/5_Makefile.i 1.5 644))
+  (Src/Makefile.in (STk/X/5_Makefile.i 1.7 644))
-  (Src/address.c (STk/X/6_address.c 1.1 444))
+  (Src/address.c (STk/X/6_address.c 1.1 644))
-  (Src/argv.c (STk/X/7_argv.c 1.1 444))
+  (Src/argv.c (STk/X/7_argv.c 1.2 644))
-  (Src/boolean.c (STk/X/8_boolean.c 1.1 444))
+  (Src/boolean.c (STk/X/8_boolean.c 1.1 644))
-  (Src/char.c (STk/X/9_char.c 1.1 444))
+  (Src/char.c (STk/X/9_char.c 1.1 644))
   (Src/configure (STk/X/10_configure 1.1 555))
   (Src/configure.in (STk/X/11_configure. 1.1 444))
   (Src/cont.c (STk/X/12_cont.c 1.2 644))
-  (Src/dummy.c (STk/X/13_dummy.c 1.1 444))
+  (Src/dummy.c (STk/X/13_dummy.c 1.1 644))
-  (Src/dump.c (STk/X/14_dump.c 1.1 444))
+  (Src/dump.c (STk/X/14_dump.c 1.1 644))
-  (Src/dynload.c (STk/X/15_dynload.c 1.2 644))
+  (Src/dynload.c (STk/X/15_dynload.c 1.5 644))
   (Src/env.c (STk/X/16_env.c 1.5 644))
-  (Src/error.c (STk/X/17_error.c 1.4 644))
+  (Src/error.c (STk/X/17_error.c 1.5 644))
   (Src/eval.c (STk/X/18_eval.c 1.10 644))
   (Src/extend.c (STk/X/19_extend.c 1.2 644))
   (Src/extend.h (STk/X/20_extend.h 1.1 444))
@@ -894,54 +893,54 @@
   (Src/gc.h (STk/X/22_gc.h 1.1 444))
   (Src/hash.c (../Extensions/hash.c) :symlink)
   (Src/html.c (../Extensions/html.c) :symlink)
-  (Src/io.c (STk/X/23_io.c 1.2 644))
+  (Src/io.c (STk/X/23_io.c 1.3 644))
   (Src/jpeg.c (../Extensions/jpeg.c) :symlink)
-  (Src/keyword.c (STk/X/24_keyword.c 1.1 444))
+  (Src/keyword.c (STk/X/24_keyword.c 1.1 644))
-  (Src/list.c (STk/X/25_list.c 1.1 444))
+  (Src/list.c (STk/X/25_list.c 1.1 644))
   (Src/macros.c (STk/X/26_macros.c 1.2 644))
-  (Src/module.c (STk/X/27_module.c 1.8 644))
+  (Src/module.c (STk/X/27_module.c 1.9 644))
   (Src/module.h (STk/X/28_module.h 1.2 644))
   (Src/number.c (STk/X/29_number.c 1.2 644))
   (Src/pixmap.c (../Extensions/pixmap.c) :symlink)
-  (Src/port.c (STk/X/30_port.c 1.6 644))
+  (Src/port.c (STk/X/30_port.c 1.10 644))
   (Src/posix.c (../Extensions/posix.c) :symlink)
   (Src/primitives.c (STk/X/31_primitives 1.10 644))
-  (Src/print.c (STk/X/32_print.c 1.3 644))
+  (Src/print.c (STk/X/32_print.c 1.4 644))
   (Src/proc.c (STk/X/33_proc.c 1.3 644))
   (Src/process.c (../Extensions/process.c) :symlink)
-  (Src/promise.c (STk/X/34_promise.c 1.1 444))
+  (Src/promise.c (STk/X/34_promise.c 1.1 644))
-  (Src/read.c (STk/X/35_read.c 1.3 644))
+  (Src/read.c (STk/X/35_read.c 1.4 644))
   (Src/run-stk.in (STk/X/36_run-stk.in 1.1 444))
   (Src/signal.c (STk/X/37_signal.c 1.4 644))
-  (Src/slib.c (STk/X/38_slib.c 1.6 644))
+  (Src/slib.c (STk/X/38_slib.c 1.8 644))
   (Src/socket.c (../Extensions/socket.c) :symlink)
-  (Src/sport.c (STk/X/39_sport.c 1.1 444))
+  (Src/sport.c (STk/X/39_sport.c 1.1 644))
   (Src/sport.h (STk/X/40_sport.h 1.1 444))
   (Src/sregexp.c (../Extensions/sregexp.c) :symlink)
-  (Src/stk.c (STk/X/41_stk.c 1.1 444))
+  (Src/stk.c (STk/X/41_stk.c 1.1 644))
-  (Src/stk.h (STk/X/42_stk.h 1.12 644))
+  (Src/stk.h (STk/X/42_stk.h 1.13 644))
-  (Src/stklos.c (STk/X/43_stklos.c 1.13 644))
+  (Src/stklos.c (STk/X/43_stklos.c 1.14 644))
   (Src/stklos.h (STk/X/44_stklos.h 1.5 644))
   (Src/str.c (STk/X/45_str.c 1.1 644))
-  (Src/symbol.c (STk/X/46_symbol.c 1.1 444))
+  (Src/symbol.c (STk/X/46_symbol.c 1.1 644))
-  (Src/syntax.c (STk/X/47_syntax.c 1.2 444))
+  (Src/syntax.c (STk/X/47_syntax.c 1.3 644))
-  (Src/tcl-glue.c (STk/X/48_tcl-glue.c 1.5 644))
+  (Src/tcl-glue.c (STk/X/48_tcl-glue.c 1.6 644))
   (Src/tcl-glue.h (STk/X/49_tcl-glue.h 1.2 644))
-  (Src/tcl-lib.c (STk/X/50_tcl-lib.c 1.2 644))
+  (Src/tcl-lib.c (STk/X/50_tcl-lib.c 1.3 644))
   (Src/tcl-obj.c (STk/X/51_tcl-obj.c 1.3 644))
-  (Src/tcl-util.c (STk/Y/0_tcl-util.c 1.1 444))
+  (Src/tcl-util.c (STk/Y/0_tcl-util.c 1.1 644))
   (Src/test-stk (STk/Y/1_test-stk 1.1 755))
   (Src/tk-glue.c (STk/Y/2_tk-glue.c 1.4 644))
   (Src/tk-glue.h (STk/Y/3_tk-glue.h 1.2 644))
   (Src/tk-main.c (STk/Y/4_tk-main.c 1.3 644))
-  (Src/tk-util.c (STk/Y/5_tk-util.c 1.1 444))
+  (Src/tk-util.c (STk/Y/5_tk-util.c 1.1 644))
-  (Src/toplevel.c (STk/Y/6_toplevel.c 1.5 644))
+  (Src/toplevel.c (STk/Y/6_toplevel.c 1.6 644))
-  (Src/trace.c (STk/Y/7_trace.c 1.1 444))
+  (Src/trace.c (STk/Y/7_trace.c 1.1 644))
   (Src/unix.c (STk/Y/8_unix.c 1.3 644))
   (Src/userinit.c (STk/Y/9_userinit.c 1.1 644))
   (Src/values.c (STk/e/b/10_values.c 1.1 644))
-  (Src/vector.c (STk/Y/11_vector.c 1.1 444))
+  (Src/vector.c (STk/Y/11_vector.c 1.1 644))
-  (Src/wstk.c (STk/Y/12_wstk.c 1.1 444))
+  (Src/wstk.c (STk/Y/12_wstk.c 1.2 644))
 
 ;; Stack Management Directory
   (Stack/libstack.h.in (STk/Y/13_libstack.h 1.1 644))
@@ -962,7 +961,7 @@
   (Stack/README (STk/Y/28_README 1.1 644))
 
 ;; Tcl Directory (only part which are useful for STk)
-  (Tcl/Makefile.in (STk/Y/29_Makefile.i 1.2 644))
+  (Tcl/Makefile.in (STk/Y/29_Makefile.i 1.3 644))
   (Tcl/README (STk/Y/30_README 1.1 644))
   (Tcl/compat/README (STk/Y/31_README 1.1 444))
   (Tcl/compat/dirent.h (STk/Y/32_dirent.h 1.1 444))
@@ -990,10 +989,10 @@
   (Tcl/license.terms (STk/Z/2_license.te 1.1 644))
   (Tcl/panic.c (STk/Z/3_panic.c 1.1 644))
   (Tcl/regexp.c (STk/Z/4_regexp.c 1.1 644))
-  (Tcl/tcl.h (STk/Z/5_tcl.h 1.1 644))
+  (Tcl/tcl.h (STk/Z/5_tcl.h 1.2 644))
   (Tcl/tclAsync.c (STk/Z/6_tclAsync.c 1.1 644))
   (Tcl/tclConfig.sh.in (STk/Z/7_tclConfig. 1.1 644))
-  (Tcl/tclEvent.c (STk/Z/8_tclEvent.c 1.2 644))
+  (Tcl/tclEvent.c (STk/Z/8_tclEvent.c 1.3 644))
   (Tcl/tclGet.c (STk/Z/9_tclGet.c 1.1 644))
   (Tcl/tclHash.c (STk/Z/10_tclHash.c 1.1 644))
   (Tcl/tclInt.h (STk/Z/11_tclInt.h 1.2 644))
@@ -1150,14 +1149,14 @@
   (Tk/unix/tkUnixScale.c (STk/c/b/3_tkUnixScal 1.2 644))
   (Tk/unix/tkUnixScrlbr.c (STk/c/b/4_tkUnixScrl 1.1 644))
   (Tk/unix/tkUnixSelect.c (STk/c/b/5_tkUnixSele 1.1 644))
-  (Tk/unix/tkUnixSend.c (STk/c/b/6_tkUnixSend 1.1 644))
+  (Tk/unix/tkUnixSend.c (STk/c/b/6_tkUnixSend 1.2 644))
   (Tk/unix/tkUnixWm.c (STk/c/b/7_tkUnixWm.c 1.2 644))
   (Tk/unix/tkUnixXId.c (STk/c/b/8_tkUnixXId. 1.1 644))
 
 ;; Utilities directory
   (Utils/install-sh (STk/c/b/9_install-sh 1.1 555))
   (Utils/STk.spec.in (STk/e/b/20_STk.spec.i 1.9 644))
-  (Utils/STk.spec (STk/e/b/21_STk.spec 1.9 644))
+  (Utils/STk.spec (STk/e/b/21_STk.spec 1.10 644))
   
   
 

STklos/Tk/Basics.stklos

@@ -11,25 +11,27 @@
 ;;;; permission of the copyright holder.  
 ;;;; This software is provided ``as is'' without express or implied warranty.
 ;;;;
-;;;; $Id: Basics.stklos 1.11 Mon, 27 Apr 1998 13:39:00 +0000 eg $
+;;;; $Id: Basics.stklos 1.12 Sat, 06 Jun 1998 12:19:03 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 30-Mar-1993 15:39
-;;;; Last file update: 27-Apr-1998 12:30
+;;;; Last file update:  1-Jun-1998 18:21
 
 (require "Tk-meta")
 
 (select-module STklos+Tk)
 
-(export Id->instance 		    ; really necessary?
+(export <Tk-object>		    ; The base class of all STklos widgets
+	<destroyed-object>	    ; Class in which destroyed objects are mapped
+	Id->instance 		    ; really necessary?
 	parent			    ; Parent of a widget
 	Id			    ; Tk Id of a widget
 	Eid			    ; External Id of widget
 	tk-widget? 		    ; a predicate
 	initialize-composite-widget ; must be overloaded for composite widgets
 	get-Tk-default-value	    ; Find the default value of a given Tk option
+	tk-constructor		    ; Returns the Tk-command associated to a class
 	destroy			    ; A redefinition of the Tk destroy
-	<destroyed-object>	    ; Class in which destroyed objects are mapped
 	focus			    ; A redefinition of the Tk focus
 	bind			    ; A redefinition of the Tk bind
 	unpack)			    ; to avoid the (pack 'unpack ...) construction

STklos/Tk/Tk-classes.stklos

@@ -11,11 +11,11 @@
 ;;;; permission of the copyright holder.  
 ;;;; This software is provided ``as is'' without express or implied warranty.
 ;;;;
-;;;; $Id: Tk-classes.stklos 1.12 Thu, 30 Apr 1998 14:16:40 +0000 eg $
+;;;; $Id: Tk-classes.stklos 1.13 Thu, 28 May 1998 20:07:43 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 19-Sep-1994 16:00
-;;;; Last file update: 30-Apr-1998 12:53
+;;;; Last file update: 22-May-1998 10:43
 
 
 (require "Tk-meta")	; for all the Tk meta classes
@@ -33,7 +33,8 @@
        (export ,@l)))
 
   ;====  Basic Tk widgets
-  (make-autoload "Basics"  	<Tk-composite-widget> <Tk-simple-widget>)
+  (make-autoload "Basics"  	<Tk-composite-widget> <Tk-composite-toplevel> 
+				<Tk-simple-widget>)
   (make-autoload "Button"  	<Label> <Button> <Check-button> <Radio-button>)
   (make-autoload "Canvas"  	<Canvas> <canvas-group> <Tk-canvas-item>)
   (make-autoload "Entry"   	<Entry>)

STklos/Tk/Tk-meta.stklos

@@ -11,11 +11,11 @@
 ;;;; permission of the copyright holder.  
 ;;;; This software is provided ``as is'' without express or implied warranty.
 ;;;;
-;;;; $Id: Tk-meta.stklos 1.8 Fri, 10 Apr 1998 07:13:18 +0000 eg $
+;;;; $Id: Tk-meta.stklos 1.9 Sat, 06 Jun 1998 12:19:03 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 24-Feb-1994 15:08
-;;;; Last file update:  6-Apr-1998 10:03
+;;;; Last file update:  1-Jun-1998 18:22
 ;;;;
 ;;;;
 ;;;; Compatibility:
@@ -46,12 +46,15 @@
 						; to STklos+Tk module
 
 ;;;;
-;;;; Metaclases exported by this file 
+;;;; Exports
 ;;;;
 (export 
+    ;; Metaclases exported by this file 
     <With-Tk-virtual-slots-metaclass> <Tk-metaclass> <Tk-item-metaclass>
     <Tk-tag-metaclass> <Tk-text-window-metaclass> <Tk-composite-metaclass>
-    <Tk-composite-item-metaclass>)
+    <Tk-composite-item-metaclass>
+    ;; generic functions exported by this file
+    compute-tk-virtual-get-n-set)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;

STklos/stklos.stk

@@ -12,11 +12,11 @@
 ;;;; permission of the copyright holder.  
 ;;;; This software is provided ``as is'' without express or implied warranty.
 ;;;;
-;;;; $Id: stklos.stk 1.21 Thu, 30 Apr 1998 14:16:40 +0000 eg $
+;;;; $Id: stklos.stk 1.23 Sun, 31 May 1998 17:22:09 +0000 eg $
 ;;;;
 ;;;;           Author: Erick Gallesio [eg@unice.fr]
 ;;;;    Creation date: 20-Feb-1994 21:09
-;;;; Last file update: 30-Apr-1998 15:47
+;;;; Last file update: 31-May-1998 13:11
 
 (when (provided? "stklos") 
   (error "STklos already initialized."))
@@ -72,6 +72,12 @@
 		   (for-each* fct (cdr l)))
 	(else      (fct l))))
 
+(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 (set-symbol! symbol value env)
   (let ((module (%get-module env)))
@@ -196,13 +202,13 @@
 		    (map (lambda (x) (%find-class x env)) supers))))
     ;; Verify that all direct slots are different and that we don't inherit
     ;; several time from the same class
-    (let ((s (list->set supers))
+    (let ((tmp1 (find-duplicate supers))
-	  (m (list->set (map slot-definition-name slots))))
+	  (tmp2 (find-duplicate (map slot-definition-name slots))))
-      (when  (< (length m) (length slots))
+      (when tmp1
-	(error "define-class: bad list of slots ~S" slots))
+	(error "define-class: super class ~S is duplicate in class ~S" tmp1 name))
-      (when (< (length s) (length supers))
+      (when tmp2
-	(error "define-class: bad list of superclasses ~S" supers)))
+	(error "define-class: slot ~S is duplicate in class ~S" tmp2 name)))
-    
+
     ;; Everything seems correct, build the class
     (let ((old (%find-class name env #f))
 	  (cls (apply make metaclass :dsupers supers :slots slots 
@@ -677,6 +683,12 @@
 			   (cddr r)
 			   (Loop (cdr l))))))))
 
+    (:each-subclass ;; slot shared by instances of direct subclass.
+		    ;; (Thomas Buerger, April 1998)
+     		    (let ((shared-cell (make-vector 1)))
+		      (list (lambda (o)   (vector-ref  shared-cell 0))
+			    (lambda (o v) (vector-set! shared-cell 0 v)))))
+
     (: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))

Src/Makefile.in

@@ -11,11 +11,11 @@
 # permission of the copyright holder.  
 # This software is provided ``as is'' without express or implied warranty.
 #
-# $Id: Makefile.in 1.5 Mon, 27 Apr 1998 13:39:00 +0000 eg $
+# $Id: Makefile.in 1.7 Sat, 06 Jun 1998 12:19:03 +0000 eg $
 #
 #           Author: Erick Gallesio [eg@unice.fr]
 #    Creation date: ??-Sep-1993 ??:??
-# Last file update: 27-Apr-1998 15:15
+# Last file update:  1-Jun-1998 18:38
 #
 
 include ../config.make

Src/argv.c

@@ -2,7 +2,7 @@
  *
  * a r g v . c			-- Argc/Argv management
  *
- * Copyright © 1993-1997 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+ * Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  * 
  *
  * Permission to use, copy, and/or distribute this software and its
@@ -19,7 +19,7 @@
  *
  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  *    Creation date: 30-Aug-1994 15:38
- * Last file update: 30-Dec-1997 14:34
+ * Last file update:  7-Jun-1998 18:01
  */
 
 #include "stk.h"
@@ -281,7 +281,8 @@ void STk_initialize_scheme_args(char **argv)
 }
 
 #ifdef WIN32
-#include <dos.h>
+
+/* #include <dos.h>   enlevé pour CYGWIN32 */
 
 char **STk_Win32_make_argc_argv(char *lpszCmdLine, int *argc)
 {

Src/dynload.c

@@ -17,11 +17,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: dynload.c 1.2 Fri, 10 Apr 1998 07:13:18 +0000 eg $
+ * $Id: dynload.c 1.5 Tue, 09 Jun 1998 07:40:04 +0000 eg $
  * 
  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  *    Creation date: 23-Jan-1994 19:09
- * Last file update:  8-Apr-1998 10:53
+ * Last file update:  8-Jun-1998 20:21
  */
 
 /* Support for HPUX is due to Dipankar Gupta <dg@hplb.hpl.hp.com> */
@@ -117,10 +117,9 @@ static void *find_function(char *path, char *fname, int error_if_absent)
   }
   else {
     /* Dynamically load the file and enter its handle in cache */
-     if ((handle = (void *) dlopen(path, DYN_FLAG)) == NULL)
+    if ((handle=(void *) dlopen(path, DYN_FLAG)) == NULL)
-       Serror("cannot open object file", str);
+      Serror("cannot open object file", str);
-     cache_files = Cons(str,
+    cache_files = Cons(str, Cons(MAKE_STAT_PTR(handle), cache_files));
-			Cons(MAKE_STAT_PTR(handle), cache_files));
   }
 
   if ((fct = (void *) dlsym(handle, fname)) == NULL && error_if_absent) {
@@ -286,6 +285,33 @@ void STk_load_object_file(char *path)
   load_and_call(path, fct_name);
 }
 
+#if defined(CYGWIN32)		
+
+#define MAKE_STAT_PTR(p) NIL
+#define MAKE_DYN_PTR(p)  NIL
+
+
+static void initialize_dynload(void)
+{
+  /* FIXME: */
+  Err("dynload: cannot initialize dynload.", STk_makestring(dlerror())); /* CYGWIN32 */
+}
+
+
+static void load_and_call(char *path, char *fct_name)
+{
+  /* FIXME */
+  Err("load-and-call: not yet implemented\n", NIL); /* CYGWIN32 */
+}
+
+static void *find_function(char *path, char *fname, int error_if_absent)
+{
+  Err("find-function: not yet implemented\n", NIL); /* CYGWIN32 */
+  return NULL;
+}
+
+#endif
+
 /******************************************************************************
  *									       
  * FFI support
@@ -561,8 +587,28 @@ PRIMITIVE STk_cstring2string(SCM pointer)
 
 
 #else /* not DYNLOAD */
+static *msg = "FFI support for this architecture does not exist yet. Sorry!";
+
 void STk_load_object_file(char *path)
 {
   Err("load: Loading of object file is not defined on this architecture", NIL);
 }
+
+PRIMITIVE STk_call_external(SCM l, int len)
+{
+  ENTER_PRIMITIVE("%call-external");
+  Serror(msg, NIL);
+}
+
+PRIMITIVE STk_external_existsp(SCM entry_name, SCM library)
+{
+  ENTER_PRIMITIVE("%external-exists?");
+  Serror(msg, NIL);
+}
+
+PRIMITIVE STk_cstring2string(SCM pointer)
+{
+  ENTER_PRIMITIVE("c-string->string");
+  Serror(msg, NIL);
+}
 #endif

Src/error.c

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: error.c 1.4 Fri, 10 Apr 1998 07:13:18 +0000 eg $
+ * $Id: error.c 1.5 Tue, 19 May 1998 10:44:58 +0000 eg $
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: 14-Nov-1993 14:58
- * Last file update:  8-Apr-1998 16:57
+ * Last file update: 14-May-1998 23:02
  */
 
 #include "stk.h"
@@ -105,7 +105,7 @@ void STk_err(char *message, SCM x)
   char head[MAX_PATH_LENGTH+50];
   
   STk_reset_eval_hook();
-  
+
   if (!(Error_context & ERR_IGNORED)) {
     if (*message) print_message(message, x);
     STk_reset_eval_stack();

Src/io.c

@@ -17,7 +17,7 @@
  *
  *	     Author: Erick Gallesio [eg@kaolin.unice.fr]
  *    Creation date: ????
- * Last file update: 26-Apr-1998 11:09
+ * Last file update:  8-Jun-1998 23:03
  */
 
 #ifdef WIN32
@@ -60,7 +60,7 @@
 #endif
 
 
-#ifdef WIN32
+#if defined(WIN32) && !defined(CYGWIN32)
   FILE *STk_stdin, *STk_stdout, *STk_stderr;
 #endif
 
@@ -82,6 +82,7 @@ static void badport(int read)
 static int nop(Tcl_Event *unused1, int unused2){ }
 
 #ifdef WIN32
+#ifndef CYGWIN32
 static insert_dummy_event(void)
 {
   struct Tcl_Event *p;
@@ -105,6 +106,7 @@ static DWORD Kbd_Thread(LPDWORD dumb)
   return 0;
 }
 #endif
+#endif
 
 void STk_StdinProc()
 {
@@ -270,7 +272,7 @@ char * STk_line_bufferize_io(FILE *f)
   {
     HANDLE Fin, Fout, Ferr;
     unsigned long dumb;
-    
+#ifdef X0       /* CYGWIN32 */
     if (AllocConsole()) {
       Fin  = GetStdHandle(STD_INPUT_HANDLE);
       Fout = GetStdHandle(STD_OUTPUT_HANDLE);
@@ -292,5 +294,6 @@ char * STk_line_bufferize_io(FILE *f)
     }
     else
       STk_panic("Cannot create Win32 console");
+#endif
   }
 #endif

Src/module.c

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: module.c 1.8 Mon, 20 Apr 1998 20:15:01 +0000 eg $
+ * $Id: module.c 1.9 Sun, 31 May 1998 17:22:09 +0000 eg $
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: 13-Mar-1997 20:11
- * Last file update: 20-Apr-1998 19:36
+ * Last file update: 31-May-1998 18:51
  */
 
 #include "stk.h"
@@ -279,6 +279,8 @@ PRIMITIVE STk_define_module(SCM l, SCM env, int len)
   module = find_module(name, FALSE, TRUE);
 
   if (len > 1) module_body(module, CDR(l));
+  STk_last_defined = name
+;
   return UNDEFINED;
 }
 

Src/port.c

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: port.c 1.6 Wed, 22 Apr 1998 21:52:02 +0000 eg $
+ * $Id: port.c 1.10 Tue, 09 Jun 1998 07:40:04 +0000 eg $
  *
  *            Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: 17-Feb-1993 12:27
- * Last file update: 22-Apr-1998 11:44
+ * Last file update:  8-Jun-1998 19:23
  *
  */
 #ifndef WIN32
@@ -49,7 +49,7 @@
 #include "stk.h"
 #include "module.h"
 
-#ifdef WIN32
+#if defined(WIN32) && !defined(CYGWIN32)
   /* Provide substitute functions dor WIN32 */
   FILE *popen(char *cmd, char *mode) 
   {	
@@ -114,26 +114,17 @@ Out:
 }
 
 
-static SCM verify_port(char *who, SCM port, int mode)
+static SCM verify_port(char *proc_name, SCM port, int mode)
 {
-  char buff[100];
-
   if (port == UNBOUND)     /* test write 'cause of flush */
     port = (mode&F_WRITE) ? STk_curr_oport: STk_curr_iport; 
 
-  if (!(INP(port) || OUTP(port))) {
+  if (!(INP(port) || OUTP(port)))     Serror("bad port", port);
-    sprintf(buff, "%s: bad port", who);
+  if (PORT_FLAGS(port) & PORT_CLOSED) Serror("port is closed", port);
-    Err(buff, port);
+
-  }
-  if (PORT_FLAGS(port) & PORT_CLOSED) {
-    sprintf(buff, "%s: port is closed", who);
-    Err(buff, port);
-  }
   if ((mode & F_READ)  && INP(port))  return port; /* not else. It can be both */
   if ((mode & F_WRITE) && OUTP(port)) return port;
-Error:
+  Serror("bad port", port);
-  sprintf(buff, "%s: bad port", who);
-  Err(buff, port);
 }
 
 static void closeport(SCM port)
@@ -250,6 +241,7 @@ static int do_load(char *full_name, SCM module)
        Top_jmp_buf   	   = prev_jb;
        Error_context 	   = prev_context;
        STk_selected_module = prev_module;
+       STk_last_defined    = Ntruth;
 
        if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
 
@@ -291,7 +283,7 @@ static int try_loadfile(char *prefix, char *fname, SCM suffixes, SCM module)
   return 0;
 
 TooLong:
-    Err("load: Filename too long", NIL);
+    Err("load: filename too long", NIL);
 }
 
 SCM STk_load_file(char *fname, int err_if_absent, SCM module)
@@ -372,9 +364,11 @@ PRIMITIVE STk_with_input_from_file(SCM string, SCM thunk)
   SCM result, prev_iport = STk_curr_iport;
   int prev_context 	 = Error_context;
   int k;
+  
+  ENTER_PRIMITIVE("with-input-from-file");
 
-  if (NSTRINGP(string))     Err("with-input-from-file: bad string", string);
+  if (NSTRINGP(string))     Serror("bad string", string);
-  if (!STk_is_thunk(thunk)) Err("with-input-from-file: bad thunk", thunk);
+  if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk);
 
   STk_curr_iport = UNBOUND; 	/* will not be changed if opening fails */
 
@@ -400,8 +394,10 @@ PRIMITIVE STk_with_output_to_file(SCM string, SCM thunk)
   int prev_context       = Error_context;
   int k;
 
-  if (NSTRINGP(string))     Err("with-output-to-file: bad string", string);
+  ENTER_PRIMITIVE("with-output-to-file");
-  if (!STk_is_thunk(thunk)) Err("with-output-to-file: bad thunk", thunk);
+
+  if (NSTRINGP(string))     Serror("bad string", string);
+  if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk);
 
   STk_curr_oport = UNBOUND;		/* will not be changed if opening fails */
 
@@ -545,8 +541,10 @@ PRIMITIVE STk_newline(SCM port)
 
 PRIMITIVE STk_write_char(SCM c, SCM port)
 {
-  if (NCHARP(c)) Err("write-char: not a character", c);
+  ENTER_PRIMITIVE("write-char");
-  port = verify_port("write-char", port, F_WRITE);
+
+  if (NCHARP(c)) Serror("not a character", c);
+  port = verify_port(proc_name, port, F_WRITE);
   Putc(CHAR(c), PORT_FILE(port));
   return UNDEFINED;
 }
@@ -576,17 +574,17 @@ static SCM internal_format(SCM l,int len,int error)/* a very simple and poor one
 {
   SCM port, fmt;
   int format_in_string = 0;
-  char *p;
+  char *p, *proc_name = error? "error": "format";
   FILE *f;
-
+  
   if (error) {
-    if (len < 1) Err("error: Bad list of parameters", l);
+    if (len < 1) Serror("bad list of parameters", l);
     format_in_string = 1;
     port = STk_open_output_string();
     len -= 1;
   }
   else {
-    if (len < 2) Err("format: Bad list of parameters", l);
+    if (len < 2) Serror("bad list of parameters", l);
     port = CAR(l); l = CDR(l);
     len -= 2;
   }
@@ -600,24 +598,28 @@ static SCM internal_format(SCM l,int len,int error)/* a very simple and poor one
     }
   }
   
-  verify_port(error? "error": "format", port, F_WRITE);
+  verify_port(proc_name, port, F_WRITE);
-  if (NSTRINGP(fmt)) Err("format: bad format string", fmt);
+  if (NSTRINGP(fmt)) Serror("bad format string", fmt);
 
   f = PORT_FILE(port);
 
   for(p=CHARS(fmt); *p; p++) {
     if (*p == '~') {
       switch(*(++p)) {
-        case 'S':
-        case 's':
         case 'A':
-        case 'a': if (len-- > 0) {
+        case 'a': if (len-- <= 0) goto TooMuch;
-                    STk_print(CAR(l), 
+	  	  STk_print(CAR(l), port, DSP_MODE);
-			      port, 
+                  l = CDR(l);
-			      (tolower(*p) == 's')? WRT_MODE: DSP_MODE);
+		  continue;
-                    l = CDR(l);
+        case 'S':
-                  }
+        case 's': if (len-- <= 0) goto TooMuch;
-                  else Err("format: too much ~ in format string", l); 
+                  STk_print(CAR(l), port, WRT_MODE);
+                  l = CDR(l);
+	          continue;        
+        case 'W':
+        case 'w': if (len-- <= 0) goto TooMuch;
+	  	  STk_print_star(CAR(l), port);
+		  l = CDR(l);
 	          continue;
         case '%': Putc('\n', f);
                   continue;
@@ -630,9 +632,12 @@ static SCM internal_format(SCM l,int len,int error)/* a very simple and poor one
     Putc(*p, f);
   }
 
-  if (NNULLP(l)) Err("format: too few ~ in format string", l);
+  if (NNULLP(l)) Serror("too few ~ in format string", l);
-
   return format_in_string ? STk_get_output_string(port) : UNDEFINED;
+
+TooMuch:
+  Serror("too much ~ in format string", l);
+  return UNDEFINED;
 }
 
 PRIMITIVE STk_format(SCM l, int len)
@@ -667,7 +672,9 @@ PRIMITIVE STk_open_file(SCM filename, SCM mode)
 {
   int type;
   
-  if (NSTRINGP(filename)) Err("open-file: bad file name", filename); 
+  ENTER_PRIMITIVE("open-file");
+
+  if (NSTRINGP(filename)) Serror("bad file name", filename); 
   if (NSTRINGP(mode) || CHARS(mode)[1] != '\0') goto Error;
   
   switch (CHARS(mode)[0]) {
@@ -675,7 +682,7 @@ PRIMITIVE STk_open_file(SCM filename, SCM mode)
     case 'w': type = tc_oport; break;
     case 'r': type = tc_iport; break;
     default:  ;
-Error:	      Err("open-file: bad mode", mode);
+Error:	     Serror("bad mode", mode);
   }
   return(makeport(CHARS(filename), type, CHARS(mode), FALSE));
 }
@@ -698,9 +705,9 @@ PRIMITIVE STk_read_line(SCM port)
   f = PORT_FILE(port);
   for (i = 0; ; i++) {
     switch (c = Getc(f)) {
-      case EOF:  if (i == 0) { free(buff); return STk_eof_object; }
+      case EOF:  if (i == 0) { free(buff); return STk_eof_object; }/* NO BREAK */
-      case '\r': i--; continue;
       case '\n': res = STk_makestrg(i, buff); free(buff); return res;
+      case '\r': i--; continue;
       default:   if (i == size) {
 	           size += size / 2;
 		   buff = must_realloc(buff, size);
@@ -713,12 +720,14 @@ PRIMITIVE STk_read_line(SCM port)
 PRIMITIVE STk_flush(SCM port)
 {
   int code;
+  
+  ENTER_PRIMITIVE("flush");
 
-  port = verify_port("flush", port, F_WRITE|F_READ);
+  port = verify_port(proc_name, port, F_WRITE|F_READ);
 
   if (! SPORTP(port)) {
     if (fflush(PORT_FILE(port)) == EOF)
-      Err("flush: cannot flush buffer", port);
+      Serror("cannot flush buffer", port);
   }
 
   return UNDEFINED;

Src/print.c

@@ -15,11 +15,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: print.c 1.3 Mon, 09 Mar 1998 08:31:40 +0000 eg $
+ * $Id: print.c 1.4 Sat, 30 May 1998 21:05:42 +0000 eg $
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: ??-Oct-1993 ??:?? 
- * Last file update:  9-Mar-1998 09:26
+ * Last file update: 30-May-1998 17:44
  *
  */
 
@@ -66,13 +66,13 @@ static void printsymbol(char *s, FILE *f, int mode)
 
 
 #ifdef USE_STKLOS
-void internal_display_instance(SCM instance, SCM port)
+static void internal_display_instance(SCM instance, SCM port)
 {
   sprintf(STk_tkbuffer, "#[instance %lx]", (unsigned long) instance);
   Puts(STk_tkbuffer, PORT_FILE(port));
 }
 
-void display_instance(SCM instance, SCM port, int type)
+static void display_instance(SCM instance, SCM port, int type)
 {
   char *fct_name;
   SCM fct;
@@ -85,7 +85,7 @@ void display_instance(SCM instance, SCM port, int type)
   }
 
   fct = STk_STklos_value(Intern(fct_name));
-  if (fct == UNBOUND) 
+  if (fct == UNBOUND)
     internal_display_instance(instance, port);
   else 
     Apply(fct, LIST2(instance, port));
@@ -384,155 +384,142 @@ SCM STk_print(SCM exp, SCM port, int mode)
   return UNDEFINED;
 }
 
-/* Printing of circular structures */
 
-static struct Tcl_HashTable cycle_table;
+/*============================================================================= 
-static int index_label;
+ * 
+ *			Printing of circular structures 
+ *
+ *=============================================================================*/
+
+static SCM cycles      = NULL;
+static int index_label = 0;
+
 static void pass1(SCM exp);		/* pass 1: mark cells */
-static SCM pass2(SCM exp, SCM port);	/* pass 2: print      */
+static void pass2(SCM exp, SCM port);	/* pass 2: print      */
 
-static int get_def_label(SCM exp)
-{
-  Tcl_HashEntry *entry;
-  int new;
-  SCM val;
 
-  entry = Tcl_FindHashEntry(&cycle_table, (char*) exp);
+static void print_cycle(SCM exp, SCM port)
-  if (!entry) panic("Internal error within STk_print_label");
+{  
-  val = (SCM) Tcl_GetHashValue(entry);
+  SCM value, tmp;
-  
+
-  if (INTEGERP(val)) {
+  if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
-    Tcl_SetHashValue(entry, Cons(val, val));
+    if (INTEGERP(value = CDR(tmp))) {
-    return INTEGER(val);
+      char buffer[50];
+      sprintf(buffer, "#%d#", INTEGER(value));
+      Puts(buffer, PORT_FILE(port));
+      return;
+    }
   }
-  return -1;
+  /* This is not a cycle. Do a normal print */
-}
+  pass2(exp, port);
-
-static int get_use_label(SCM exp)
-{
-  Tcl_HashEntry *entry;
-
-  entry = Tcl_FindHashEntry(&cycle_table, (char*) exp);
-  if (entry) {
-    SCM val = (SCM) Tcl_GetHashValue(entry);
-    
-    if (CONSP(val)) return INTEGER(CAR(val));
-  }
-  return -1;
 }
 
 
 static void printlist_star(SCM exp, SCM port)
 {
+  SCM value, tmp;
   FILE *f = PORT_FILE(port);
-  char buffer[50];
-  int label;
 
-  if ((label = get_def_label(exp)) >= 0) {
+  Putc('(', f);
-    sprintf(buffer, "#%d=", label);
-    Puts(buffer, f);
-  }
 
-  Putc('(', f); 
-  
   for ( ; ; ) {
-    if ((label = get_use_label(CAR(exp))) >= 0) {
+    print_cycle(CAR(exp), port);
-      sprintf(buffer, "#%d#", label);
-      Puts(buffer, f);
-    }
-    else pass2(CAR(exp), port);
-    
-    exp = CDR(exp);
 
-    if (NULLP(exp)) break;
+    if (NULLP(exp=CDR(exp))) break;
-    if  ((label = get_use_label(exp)) >= 0) {
+
-      sprintf(buffer, " . #%d#", label);
+    if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
-      Puts(buffer, f);
+      value = CDR(tmp);
-      break;
+      if (NCONSP(exp) || value == Truth || INTEGERP(value)) { 
-    }
+	/* either  ". X" or ". #0=(...)" or ". #0#" */
-    if (NCONSP(exp)) {
+	Puts(" . ", f);
-      Puts(" . ", f);
+	print_cycle(exp, port);
-      pass2(exp, port);
+	break;
-      break;
+      }
     }
     Putc(' ', f);
   }
   Putc(')', f);
 }
 
+
 static void printvector_star(SCM exp, SCM port)
 {
   FILE *f = PORT_FILE(port);
-  char buffer[50];
+  int j, n = exp->storage_as.vector.dim;
-  int i, label, len = VECTSIZE(exp);;
-
-  if ((label = get_def_label(exp)) >= 0) {
-    sprintf(buffer, "#%d=", label);
-    Puts(buffer, f);
-  }
-
-  Puts("#(", f);
   
-  for (i = 0; i < len; i++) {
+  Puts("#(", f);
-    SCM tmp = VECT(exp)[i];
+  for(j=0; j < n; j++) {
-    if ((label = get_use_label(tmp)) >= 0) {
+    print_cycle(VECT(exp)[j], port);
-      sprintf(buffer, "#%d#", label);
+    if ((j + 1) < n) Putc(' ', f);
-      Puts(buffer, f);
-    }
-    else pass2(tmp, port);
-    if (i < len-1) Putc(' ', f);
   }
   Putc(')', f);
 }
 
+
 static void pass1(SCM exp)
 {
-  Tcl_HashEntry *entry;
+  SCM tmp;
-  int new;
 
+Top:
   if (NCONSP(exp) && NVECTORP(exp)) return;
 
-  entry = Tcl_CreateHashEntry(&cycle_table, (char *) exp, &new);
+  if ((tmp = STk_assv(exp, cycles)) == Ntruth) {
-  if (new) {
+    /* We have never seen this cell so far */
-    /* We have never seen this cell */
+    cycles = Cons(Cons(exp, Ntruth), cycles);
-    Tcl_SetHashValue(entry, Truth);
+
-    switch (TYPE(exp)) {
+    if (CONSP(exp)) {			/* it's a cons */
-      case tc_cons:   pass1(CAR(exp)); pass1(CDR(exp)); break;
+      pass1(CAR(exp));
-      case tc_vector: {
+      exp = CDR(exp); 
-			int i, len = VECTSIZE(exp);
+      goto Top;
-			for (i = 0; i < len; i++) pass1(VECT(exp)[i]);
-      		      }
-      		      break;
     }
-  }
+    else { 				/* it's a vector */
+      int i, len = VECTSIZE(exp)-1;
+      for (i = 0; i < len; i++) pass1(VECT(exp)[i]);
+      if (len >= 0) {exp = VECT(exp)[len]; goto Top;}
+    }
+  } 
   else {
-    SCM val = (SCM) Tcl_GetHashValue(entry);
+    /* This item was already seen. Note that this is the second time */
-    if (val == Truth)
+    CDR(tmp) = Truth;
-      /* No label has been assigned to this cell. Provide one */
-      Tcl_SetHashValue(entry, (char *) STk_makeinteger(index_label++));
   }
 }
 
-static SCM pass2(SCM exp, SCM port)
-{
-  FILE *f = PORT_FILE(port);
 
-  switch (TYPE(exp)) {
+static void pass2(SCM exp, SCM port)
-    case tc_cons:   printlist_star(exp, port);   break;
+{
-    case tc_vector: printvector_star(exp, port); break;
+  if (NCONSP(exp) && NVECTORP(exp))
-    default:  STk_print(exp, port, WRT_MODE);
+    STk_print(exp, port, WRT_MODE); 	/* Normal print */
+  else {
+    SCM value, tmp;
+
+    /* Eventually print a definition label */
+    if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
+      if ((value=CDR(tmp)) == Truth) {
+	FILE *f = PORT_FILE(port);
+	char buffer[50];
+	int label;
+
+	/* First use of this label. Assign it a value */
+	sprintf(buffer, "#%d=", index_label);
+	Puts(buffer, f);
+	CDR(tmp) = STk_makeinteger(index_label++);
+      }
+    }
+
+    if (CONSP(exp)) printlist_star(exp, port);
+    else            printvector_star(exp, port);
   }
 }
 
-SCM STk_print_star(SCM exp, SCM port)
+PRIMITIVE STk_print_star(SCM exp, SCM port)
 {
-  if (NCONSP(exp) &&  NVECTORP(exp)) 
+  if (NCONSP(exp) &&  NVECTORP(exp)) return STk_print(exp, port, WRT_MODE);
-    return STk_print(exp, port, WRT_MODE);
+
-  
+  if (cycles == NULL) STk_gc_protect(&cycles);
-  Tcl_InitHashTable(&cycle_table, TCL_ONE_WORD_KEYS);
+  cycles      = NIL;
   index_label = 0;
 
-  pass1(exp);
+  pass1(exp); pass2(exp, port);
-  pass2(exp, port);
+
   return UNDEFINED;
 }

Src/read.c

@@ -15,11 +15,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: read.c 1.3 Sun, 01 Feb 1998 22:14:16 +0000 eg $
+ * $Id: read.c 1.4 Thu, 28 May 1998 20:07:43 +0000 eg $
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: ??-Oct-1993 ??:?? 
- * Last file update:  1-Feb-1998 18:27
+ * Last file update: 25-May-1998 20:26
  *
  */
 
@@ -27,7 +27,11 @@
 #include "stk.h"
 #include "module.h"
 
-static SCM lreadr(FILE *f, int case_significant);
+static SCM cycles = NULL;		/* used for reading circular data */
+static char *proc_name = "read";	/* for Serror macro */	
+
+
+static SCM read_rec(FILE *f, int case_significant);
 
 
 static int flush_ws(FILE *f, char *message)
@@ -37,7 +41,7 @@ static int flush_ws(FILE *f, char *message)
   c = Getc(f);
   for ( ; ; ) {
     switch (c) {
-      case EOF:  if (message) Err(message,NIL); else return(c);
+      case EOF:  if (message) Serror(message,NIL); else return(c);
       case ';':  do 
 		   c = Getc(f); 
 		 while (c != '\n' && c != EOF);
@@ -49,7 +53,7 @@ static int flush_ws(FILE *f, char *message)
   }
 }
 
-static SCM lreadlist(FILE *f, char delim, int case_significant)
+static SCM read_list(FILE *f, char delim, int case_significant)
 /* Read a list ended by the `delim' char */
 {
   int c;
@@ -60,19 +64,19 @@ static SCM lreadlist(FILE *f, char delim, int case_significant)
 
   /* Read the car */
   Ungetc(c, f);
-  tmp = lreadr(f, case_significant);
+  tmp = read_rec(f, case_significant);
   
   /* Read the cdr */
   if (EQ(tmp, Sym_dot)) {
-    tmp = lreadr(f, case_significant);
+    tmp = read_rec(f, case_significant);
     c = flush_ws(f, "End of file inside list");
-    if (c != delim) Err("Missing close parenthesis", NIL);
+    if (c != delim) Serror("missing close parenthesis", NIL);
     return(tmp);
   }
-  return(Cons(tmp, lreadlist(f, delim, case_significant)));
+  return(Cons(tmp, read_list(f, delim, case_significant)));
 }
 
-static void lreadword(FILE *f, int c, int case_significant) 
+static void read_word(FILE *f, int c, int case_significant) 
 /* read an item whose 1st char is in c */
 { 
   register int j = 0;
@@ -92,13 +96,13 @@ static void lreadword(FILE *f, int c, int case_significant)
       }
       if (isspace(c)) break;
     }
-    if (j >= TKBUFFERN-1) Err("read: token too large", NIL);
+    if (j >= TKBUFFERN-1) Serror("token too large", NIL);
   }
 
   STk_tkbuffer[j] = '\0';
 }
 
-static void lreadchar(FILE *f, int c)
+static void read_char(FILE *f, int c)
 /* read an char (or a char name) item whose 1st char is in c */
 { 
   register int j = 0;
@@ -111,23 +115,23 @@ static void lreadchar(FILE *f, int c)
       Ungetc(c, f);
       break;
     }
-    if (j >= TKBUFFERN-1) Err("read: token too large", NIL);
+    if (j >= TKBUFFERN-1) Serror("token too large", NIL);
   }
   STk_tkbuffer[j] = '\0';
 }
   
-static SCM lreadtoken(FILE *f, int c, int case_significant) 
+static SCM read_token(FILE *f, int c, int case_significant) 
 {
   SCM z;
 
-  lreadword(f, c, case_significant);
+  read_word(f, c, case_significant);
   z = STk_Cstr2number(STk_tkbuffer, 10L);
 
   if (z == Ntruth)
     /* It is not a number */
     switch (*STk_tkbuffer) {
       case ':': return STk_makekey(STk_tkbuffer);
-      case '#': Err("bad # syntax", STk_makestring(STk_tkbuffer));
+      case '#': Serror("bad # syntax", STk_makestring(STk_tkbuffer));
       default : return Intern(STk_tkbuffer);
     }
   
@@ -135,7 +139,67 @@ static SCM lreadtoken(FILE *f, int c, int case_significant)
   return z;
 }
 
-static SCM lreadstring(FILE *f)
+static SCM read_cycle(FILE *f, int c, int case_significant)
+/* read a #xx# or #xx= cycle item whose 1st char is in c. */
+{ 
+  register int j = 0;
+
+  for( ; ; ) {
+    STk_tkbuffer[j++] = c;
+    c = Getc(f);
+    if (c == EOF || !isdigit(c)) break;
+    if (j >= TKBUFFERN-1) Serror("token too large", NIL);
+  }
+  STk_tkbuffer[j] = '\0';
+
+  switch (c) {
+    case '#': {
+		 SCM tmp, k = STk_makeinteger(atoi(STk_tkbuffer));
+		 
+		 if ((tmp = STk_assv(k, cycles)) != Ntruth) {
+		   return CDR(tmp);
+		 }
+		 else {
+		   char buffer[70];
+		   sprintf(buffer, "key ``#%d='' not defined", atoi(STk_tkbuffer));
+		   Serror(buffer, NIL);
+		 }
+    	      }
+    case '=': {
+      		 SCM val, tmp, k = STk_makeinteger(atoi(STk_tkbuffer));
+		 
+		 if ((tmp = STk_assv(k, cycles)) == Ntruth) {
+		   /* This is a little bit tricky here: We create a fake cell
+		    * that could be referenced by the further read. Once the read 
+		    * is finished, we overwrite the fake cell with the value 
+		    * returned by the read. So, the fake cell becomes the real 
+		    * result (not too clear :-).
+		    * ATTENTION: the value returned the next read can be of 
+		    * any type (e.g. '(1 2 #0="ab" #0#) ). But all our cells 
+		    * have the same size => no problem.
+		    */
+		   tmp      = Cons(UNBOUND, UNBOUND);       /* The fake cell */
+		   cycles   = Cons(Cons(k, tmp), cycles);   /* For next read */
+		   val      = read_rec(f, case_significant);/* Read item */
+		   *tmp     = *val; 			    /* Overwrt fake cell*/
+		   return tmp;
+		 }
+		 else {
+		   char buffer[70];
+		   sprintf(buffer, "key ``#%d='' already defined",
+			   atoi(STk_tkbuffer))
+;
+		   Serror(buffer, NIL);
+		 }
+    	      }
+    default:  Ungetc(c, f); Serror("bad # syntax", STk_makestring(STk_tkbuffer));
+  }
+  
+  return UNBOUND; /* for the compiler */
+}
+  
+
+static SCM read_string(FILE *f)
 {
   int j, k ,c,n,len;
   char *p, *buffer;
@@ -148,7 +212,7 @@ static SCM lreadstring(FILE *f)
   while(((c = Getc(f)) != '"') && (c != EOF)) { 
     if (c == '\\') {
       c = Getc(f);
-      if (c == EOF) Err("Eof after \\", NIL);
+      if (c == EOF) Serror("eof encountered after \\", NIL);
       switch(c) {
         case 'b' : c = '\b'; break;	/* Bs  */
 	case 'e' : c = 0x1b; break;	/* Esc */
@@ -158,7 +222,7 @@ static SCM lreadstring(FILE *f)
         case '\n': STk_line_counter += 1; continue;
 	case '0' : for( k=n=0 ; ; k++ ) {
 		     c = Getc(f);
-		     if (c == EOF) Err("Eof after \\0", NIL);
+		     if (c == EOF) Serror("eof encountered after \\0", NIL);
 	             if (isdigit(c) && (c < '8') && k < 3) /* Max = 3 digits */
 		        n = n * 8 + c - '0';
 		     else {
@@ -180,7 +244,7 @@ static SCM lreadstring(FILE *f)
     j++;
     *p++ = c;
   }
-  if (c == EOF) Err("End of file while reading a string", NIL);
+  if (c == EOF) Serror("end of file while reading a string", NIL);
   *p = '\0';
   
   z = STk_makestrg(j, buffer);
@@ -189,40 +253,40 @@ static SCM lreadstring(FILE *f)
   return z;
 }
 
-static SCM lreadr(FILE *f, int case_significant)
+static SCM read_rec(FILE *f, int case_significant)
 {
   int c;
 
   for ( ; ; ) {
-    c = flush_ws(f, "End of file inside read encountered");
+    c = flush_ws(f, "end of file inside read encountered");
     
     switch (c) {
       case '(':
-        return(lreadlist(f, ')', case_significant));
+        return(read_list(f, ')', case_significant));
       case '[':
-	return(lreadlist(f, ']', case_significant));
+	return(read_list(f, ']', case_significant));
       case ')':
       case ']':
-	fprintf(STk_stderr, "\nUnexpected close parenthesis");
+	fprintf(STk_stderr, "\nread: unexpected close parenthesis");
 	if (STk_current_filename != UNBOUND)	
 	  fprintf(STk_stderr, " at line %d in file %s", 
 		  	      STk_line_counter, CHARS(STk_current_filename));
 	fprintf(STk_stderr, "\n");
 	break;
       case '\'':
-	return LIST2(Sym_quote, lreadr(f, case_significant));
+	return LIST2(Sym_quote, read_rec(f, case_significant));
       case '`':
-	return LIST2(Sym_quasiquote, lreadr(f, case_significant));
+	return LIST2(Sym_quasiquote, read_rec(f, case_significant));
       case '#':
 	switch(c=Getc(f)) {
 	  case 't':
           case 'T':  return Truth;
 	  case 'f':
 	  case 'F':  return Ntruth;
- 	  case '\\': lreadchar(f, Getc(f));
+ 	  case '\\': read_char(f, Getc(f));
 	             return STk_makechar(STk_string2char(STk_tkbuffer));
 	  case '(' : { 
-	    	       SCM l = lreadlist(f, ')', case_significant);
+	    	       SCM l = read_list(f, ')', case_significant);
 		       return STk_vector(l, STk_llength(l));
 	  	     }
 	  case '!' : while ((c=Getc(f)) != '\n')
@@ -240,11 +304,21 @@ static SCM lreadr(FILE *f, int case_significant)
 		     Ungetc(c,f);
 	  	     continue;		     
 	  case 'p':
-	  case 'P': lreadword(f, Getc(f), TRUE);
+	  case 'P': read_word(f, Getc(f), TRUE);
 	    	    return STk_address2object(STk_tkbuffer);
-	  case '.': return STk_eval(lreadr(f, case_significant), 
+	  case '.': return STk_eval(read_rec(f, case_significant), 
 				    MOD_ENV(STk_selected_module));
-	  default:  Ungetc(c, f); return lreadtoken(f, '#', FALSE);
+	  case '0':
+	  case '1':
+	  case '2':
+	  case '3':
+	  case '4':
+	  case '5':
+	  case '6':
+	  case '7':
+	  case '8':
+	  case '9': return read_cycle(f, c, case_significant);
+	  default:  Ungetc(c, f); return read_token(f, '#', FALSE);
 	}
       case ',': {
 	SCM symb;
@@ -256,12 +330,12 @@ static SCM lreadr(FILE *f, int case_significant)
 	  symb = Sym_unquote; 
 	  Ungetc(c, f);
 	}
-	return LIST2(symb, lreadr(f, case_significant));
+	return LIST2(symb, read_rec(f, case_significant));
       }
       case '"':
-	return lreadstring(f);
+	return read_string(f);
       default:
-	return lreadtoken(f, c, case_significant);
+	return read_token(f, c, case_significant);
     }
   }
 }
@@ -269,9 +343,13 @@ static SCM lreadr(FILE *f, int case_significant)
 SCM STk_readf(FILE *f, int case_significant)
 {
   int c;
-  
+  SCM sexpr, key;
+
+  if (cycles == NULL) STk_gc_protect(&cycles);
+  cycles = NIL;
+
   c = flush_ws(f, (char *) NULL);
   if (c == EOF) return(STk_eof_object);
   Ungetc(c, f);
-  return lreadr(f, case_significant);
+  return read_rec(f, case_significant);
 }

Src/slib.c

@@ -15,11 +15,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: slib.c 1.6 Fri, 10 Apr 1998 12:05:25 +0000 eg $
+ * $Id: slib.c 1.8 Tue, 09 Jun 1998 07:40:04 +0000 eg $
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: ??-Oct-1993 ??:?? 
- * Last file update: 10-Apr-1998 10:22
+ * Last file update:  7-Jun-1998 17:34
  *
  */
 
@@ -34,7 +34,7 @@
 
 #ifdef WIN32
 #   include <time.h>
-#   include <dos.h>
+/* #   include <dos.h>		enlévé pour CYGWIN32 */
 #   include <process.h>
 #else
 #   include <stdarg.h>
@@ -215,7 +215,7 @@ PRIMITIVE STk_machine_type(void)
 
 PRIMITIVE STk_library_location(void)
 {
-   return STk_makestring(STk_library_path);
+  return STk_makestring(STk_library_path);
 }
 
 PRIMITIVE STk_random(SCM n)
@@ -484,10 +484,9 @@ void Debug(char *message, SCM obj)
 #ifndef WIN32
 typedef void (*dumb)();
 
-dumb STk_dumb[] = { 
+dumb STk_dumb[] = {
   (dumb) Tcl_TildeSubst,
   (dumb) Tcl_SetVar2,
   (dumb) Tcl_NewListObj
-  
 };
 #endif

Src/stk.h

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- *  $Id: stk.h 1.12 Wed, 22 Apr 1998 21:52:02 +0000 eg $
+ *  $Id: stk.h 1.13 Tue, 19 May 1998 10:44:58 +0000 eg $
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: 12-May-1993 10:34
- * Last file update: 22-Apr-1998 11:34
+ * Last file update: 14-May-1998 16:36
  *
  ******************************************************************************/
 
@@ -88,6 +88,7 @@ extern "C" {
 #define LOAD_PATH	"*load-path*"
 #define LOAD_SUFFIXES	"*load-suffixes*"
 #define LOAD_VERBOSE	"*load-verbose*"
+#define LAST_DEFINED    "*last-defined*"
 
 #define REPORT_ERROR	"report-error"
 
@@ -1458,6 +1459,9 @@ Extern char *STk_library_path;
 /* Is the interpreter safe. Of course not!!! */
 Extern int STk_is_safe;
 
+/* The last variable defined with a DEFINE */
+Extern SCM STk_last_defined;
+
 #undef  Extern
 #define Truth 	  STk_truth
 #define Ntruth	  STk_ntruth

Src/stklos.c

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: stklos.c 1.13 Mon, 20 Apr 1998 20:15:01 +0000 eg $
+ * $Id: stklos.c 1.14 Thu, 21 May 1998 20:00:04 +0000 eg $
  *
  *            Author: Erick Gallesio [eg@unice.fr]
  *    Creation date:  9-Feb-1994 15:56
- * Last file update: 13-Apr-1998 23:13 
+ * Last file update: 19-May-1998 16:24 
  */
 
 #ifdef USE_STKLOS
@@ -596,8 +596,9 @@ static PRIMITIVE slot_boundp_using_class(SCM classe, SCM obj, SCM slot_name)
 {
   ENTER_PRIMITIVE("slot-bound-using-class?");
 
-  if (NCLASSP(classe)) Serror("bad class",  classe);
+  if (NCLASSP(classe))     Serror("bad class",  classe);
-  if (NINSTANCEP(obj)) Serror("bad object", obj);
+  if (NSYMBOLP(slot_name)) Serror("bad slot name",slot_name);
+  if (NINSTANCEP(obj))     Serror("bad object", obj);
 
   return (get_slot_value(classe, obj, slot_name) == UNBOUND) ? Ntruth : Truth;
 }

Src/syntax.c

@@ -19,7 +19,7 @@
  *
  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  *    Creation date: 25-Oct-1993 23:39
- * Last file update:  9-Jan-1998 19:03
+ * Last file update: 14-May-1998 22:55
  */
 
 /* Notes:
@@ -327,10 +327,12 @@ PRIMITIVE STk_syntax_define(SCM *pform, SCM env, int len)
 
   if (NULLP(env)) {				/* Global var */
     STk_define_public_var(NIL, var, expr);
+    STk_last_defined = var;   
   }
   else {
     if (MODULEP(CAR(env))) {			/* Public variable */
       STk_define_public_var(CAR(env), var, expr);
+      STk_last_defined = var;
     }
     else {				 	/* Local var */
       tmp = STk_value_in_env(var, env);
@@ -356,7 +358,6 @@ PRIMITIVE STk_syntax_define(SCM *pform, SCM env, int len)
       }
     }
   }
-
   if (TRACED_VARP(var)) STk_change_value(var, env);
   SYNTAX_RETURN(UNDEFINED, Ntruth);
 }

Src/tcl-glue.c

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: tcl-glue.c 1.5 Wed, 22 Apr 1998 21:52:02 +0000 eg $
+ * $Id: tcl-glue.c 1.6 Tue, 19 May 1998 10:44:58 +0000 eg $
  *
  *            Author: Erick Gallesio [eg@unice.fr]
  *    Creation date:  6-Aug-1997 12:48
- * Last file update: 22-Apr-1998 22:47
+ * Last file update: 19-May-1998 12:16
  *
  */
 
@@ -189,7 +189,7 @@ char *STk_tcl_getvar(char *name, char *env)
     return "";
   }
   else 
-    STk_convert_for_Tcl(V, &dumb);
+    return STk_convert_for_Tcl(V, &dumb);
 }
 
 

Src/tcl-lib.c

@@ -20,7 +20,7 @@
  *
  *            Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: 19-Feb-1993 22:15
- * Last file update:  1-Feb-1998 17:56
+ * Last file update:  7-Jun-1998 18:13
  *
  */
 
@@ -963,7 +963,7 @@ Tcl_JoinPath(argc, argv, resultPtr)
 		    /*
 		     * Check to see if we need to append a separator.
 		     */
-
+		    int c;
 		    
 		    if (length != oldLength) {
 			c = Tcl_DStringValue(resultPtr)[length-1];

Src/toplevel.c

@@ -16,11 +16,11 @@
  * This software is a derivative work of other copyrighted softwares; the
  * copyright notices of these softwares are placed in the file COPYRIGHTS
  *
- * $Id: toplevel.c 1.5 Mon, 27 Apr 1998 08:44:17 +0000 eg $
+ * $Id: toplevel.c 1.6 Tue, 19 May 1998 10:44:58 +0000 eg $
  *
  *	     Author: Erick Gallesio [eg@kaolin.unice.fr]
  *    Creation date:  6-Apr-1994 14:46
- * Last file update: 26-Apr-1998 18:41
+ * Last file update: 14-May-1998 22:19
  */
 
 #include "stk.h"
@@ -30,7 +30,6 @@
 /* The cell representing NIL */
 static struct obj VNIL	   = {0, tc_nil};
 
-
 static void print_banner(void)
 {
   if (STk_lookup_variable(PRINT_BANNER, NIL) != Ntruth){
@@ -113,6 +112,17 @@ static void init_library_path(char *argv0)
   }
 }
 
+static SCM get_last_defined(char *name)
+{
+  return STk_last_defined;
+}
+
+static void set_last_defined(char *name, SCM val)
+{
+  STk_last_defined = val;
+}
+
+
 static void init_interpreter(void)
 {
 #ifdef WIN32
@@ -193,6 +203,11 @@ static void init_interpreter(void)
 
   /* initialize STk_wind_stack and protect it against garbage colection */
   STk_wind_stack = NIL;	 STk_gc_protect(&STk_wind_stack);
+
+  /* Initialize C variables */
+  STk_last_defined = Ntruth;
+  STk_define_C_variable(LAST_DEFINED, get_last_defined, set_last_defined);
+  STk_gc_protect(&STk_last_defined);
 }
 
 static void finish_initialisation(void)

Src/wstk.c

@@ -2,7 +2,7 @@
  *
  * w s t k . c
  *
- * Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+ * Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  * 
  *
  * Permission to use, copy, and/or distribute this software and its
@@ -19,15 +19,21 @@
  *
  *           Author: Erick Gallesio [eg@unice.fr]
  *    Creation date: 12-May-1993 10:34
- * Last file update: 21-Jul-1996 11:50
+ * Last file update:  8-Jun-1998 19:41
  *
  ******************************************************************************/
 #define STK_MAIN
 
-#include <dos.h>
+#ifndef CYGWIN32
+#  include <dos.h>
+#endif
+
 #include <locale.h>
 #include "stk.h"
-#include "tkWinInt.h"
+
+#ifdef USE_TK
+#  include "tkWinInt.h"
+#endif
 
 void WishPanic _ANSI_ARGS_(TCL_VARARGS(char *,format));
 

Tcl/Makefile.in

@@ -8,10 +8,9 @@
 include ../config.make
 
 CFLAGS = $(STKCFLAGS) $(DFLGS) -I. -I../Src @DEFS@
-OBJ    = panic.o tclHash.o tclGet.o regexp.o tclAsync.o tclUtil.o \
+OBJ    = panic.o tclHash.o tclGet.o regexp.o tclUtil.o @LIBOBJS@
-	 tclNotify.o @LIBOBJS@
 EVOBJ  = tclEvent.o tclTimer.o tclUnixNotfy.o tclUnixTime.o  tclUnixEvent.o \
-         tclPreserve.o
+         tclPreserve.o  tclNotify.o tclAsync.o
 
 all: libtcl.a libevtcl.a
 

Tcl/tcl.h

@@ -345,7 +345,9 @@ typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
  */
 
 typedef struct Tcl_ObjType {
-#ifndef STk_CODE
+#ifdef STk_CODE
+  void *dumb;			/* for AIX */
+#else
     char *name;			/* Name of the type, e.g. "int". */
     Tcl_FreeInternalRepProc *freeIntRepProc;
 				/* Called to free any storage for the type's

Tcl/tclEvent.c

@@ -145,7 +145,7 @@ Tcl_BackgroundError(interp)
     errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1));
     strcpy(errPtr->errorMsg, errResult);
 #ifdef STk_CODE
-    varValue = STk_tcl_getvar("*error-info*", "#f");
+    varValue = (char *) STk_tcl_getvar("*error-info*", "#f");
 #else
     varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
 #endif

Tk/unix/tkUnixSend.c

@@ -602,7 +602,7 @@ ValidateName(dispPtr, name, commWindow, oldOK)
 	    dispPtr->appNameProperty, 0, MAX_PROP_WORDS,
 	    False, XA_STRING, &actualType, &actualFormat,
 	    &length, &bytesAfter, (unsigned char **) &property);
-
+ 
     if ((result == Success) && (actualType == None)) {
 	XWindowAttributes atts;
 
@@ -802,7 +802,11 @@ Tk_SetAppName(tkwin, name)
 	    if (i == 2) {
 		Tcl_DStringInit(&dString);
 		Tcl_DStringAppend(&dString, name, -1);
+#ifdef STk_CODE
+		Tcl_DStringAppend(&dString, "#", 1);
+#else
 		Tcl_DStringAppend(&dString, " #", 2);
+#endif
 		offset = Tcl_DStringLength(&dString);
 		Tcl_DStringSetLength(&dString, offset+10);
 		actualName = Tcl_DStringValue(&dString);

Utils/STk.spec

@@ -1,17 +1,17 @@
 %define		release 1
 Summary: 	Scheme Interpreter with access to the Tk toolkit
 Name:    	STk
-Version: 	3.99.1
+Version: 	3.99.2
 Release: 	%{release}
 Copyright: 	distributable
-Source: 	STk-3.99.1.tar.gz
+Source: 	STk-3.99.2.tar.gz
 Group:		Development/Languages
 Packager:	Erick Gallesio <eg@unice.fr>
 
 %package devel
 Summary: 	Header files and libraries for STk
 Group: 		Development/Libraries
-Requires:	STk = 3.99.1
+Requires:	STk = 3.99.2
 
 %description
 STk is a R4RS Scheme interpreter which can access the Tk graphical
@@ -60,22 +60,22 @@ rm -f /usr/local/lib/stk/include
 
 %files
 %doc README INSTALL CHANGES ChangeLog
-/usr/local/lib/stk/3.99.1/Demos
+/usr/local/lib/stk/3.99.2/Demos
-/usr/local/lib/stk/3.99.1/Help
+/usr/local/lib/stk/3.99.2/Help
-/usr/local/lib/stk/3.99.1/Images
+/usr/local/lib/stk/3.99.2/Images
-/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/stk
+/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/stk
-/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/snow
+/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/snow
-/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/*.so
+/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/*.so
-/usr/local/lib/stk/3.99.1/STk
+/usr/local/lib/stk/3.99.2/STk
-/usr/local/lib/stk/3.99.1/include
+/usr/local/lib/stk/3.99.2/include
-/usr/local/lib/stk/3.99.1/man
+/usr/local/lib/stk/3.99.2/man
-/usr/local/bin/stk-3.99.1
+/usr/local/bin/stk-3.99.2
-/usr/local/bin/snow-3.99.1
+/usr/local/bin/snow-3.99.2
 /usr/local/bin/stk
 /usr/local/bin/snow
 
 
 
 %files devel
-/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/Config
+/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/Config
-/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/Libs
+/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/Libs

VERSION

@@ -1 +1 @@
-VERSION=3.99.1
+VERSION=3.99.2

configure

@@ -544,7 +544,7 @@ fi
 
 
 
-VERSION=3.99.1
+VERSION=3.99.2
 echo "VERSION=$VERSION" > VERSION
 
 # I have a lot of problems with cache. So ...
@@ -677,6 +677,26 @@ echo "Assumming OS is $OS"
 ####
 #### X11 stuff
 ####
+echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6
+if test -d /etc/conf/kconfig.d &&
+  grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1
+then
+  echo "$ac_t""yes" 1>&6
+  ISC=yes # If later tests want to check for ISC.
+  cat >> confdefs.h <<\EOF
+#define _POSIX_SOURCE 1
+EOF
+
+  if test "$GCC" = yes; then
+    CC="$CC -posix"
+  else
+    CC="$CC -Xp"
+  fi
+else
+  echo "$ac_t""no" 1>&6
+  ISC=
+fi
+		# to avoid a warning
 echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
 # On Suns, sometimes $CPP names a directory.
 if test -n "$CPP" && test -d "$CPP"; then
@@ -692,7 +712,7 @@ else
   # On the NeXT, cc -E runs the code through the compiler's parser,
   # not just through cpp.
   cat > conftest.$ac_ext <<EOF
-#line 696 "configure"
+#line 716 "configure"
 #include "confdefs.h"
 #include <assert.h>
 Syntax Error
@@ -706,7 +726,7 @@ else
   rm -rf conftest*
   CPP="${CC-cc} -E -traditional-cpp"
   cat > conftest.$ac_ext <<EOF
-#line 710 "configure"
+#line 730 "configure"
 #include "confdefs.h"
 #include <assert.h>
 Syntax Error
@@ -792,7 +812,7 @@ test -z "$x_direct_test_library" && x_direct_test_library=Xt
 test -z "$x_direct_test_function" && x_direct_test_function=XtMalloc
 test -z "$x_direct_test_include" && x_direct_test_include=X11/Intrinsic.h
 cat > conftest.$ac_ext <<EOF
-#line 796 "configure"
+#line 816 "configure"
 #include "confdefs.h"
 #include <$x_direct_test_include>
 EOF
@@ -855,7 +875,7 @@ rm -f conftest*
 ac_save_LIBS="$LIBS"
 LIBS="-l$x_direct_test_library $LIBS"
 cat > conftest.$ac_ext <<EOF
-#line 859 "configure"
+#line 879 "configure"
 #include "confdefs.h"
 
 int main() { return 0; }
@@ -937,26 +957,6 @@ else
   echo "$ac_t""libraries $x_libraries, headers $x_includes" 1>&6
 fi
 
-echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6
-if test -d /etc/conf/kconfig.d &&
-  grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1
-then
-  echo "$ac_t""yes" 1>&6
-  ISC=yes # If later tests want to check for ISC.
-  cat >> confdefs.h <<\EOF
-#define _POSIX_SOURCE 1
-EOF
-
-  if test "$GCC" = yes; then
-    CC="$CC -posix"
-  else
-    CC="$CC -Xp"
-  fi
-else
-  echo "$ac_t""no" 1>&6
-  ISC=
-fi
-
 if test "$no_x" = yes; then 
   # Not all programs may use this symbol, but it does not hurt to define it.
   X_CFLAGS="$X_CFLAGS -DX_DISPLAY_MISSING"
@@ -1590,7 +1590,7 @@ case $OS in
      # Add the -ldld flag 
      LIB_DLD=-ldld;;
    LINUX_ELF)
-     SH_CCFLAGS=''
+     SH_CCFLAGS='-fpic'
      SH_LDFLAGS='-shared -o'
      SH_LOADER='ld'
      SH_SUFFIX='so' 

configure.in

@@ -5,7 +5,7 @@ dnl	to configure the system for the local environment.
 
 AC_INIT(README)
 
-VERSION=3.99.1
+VERSION=3.99.2
 echo "VERSION=$VERSION" > VERSION
 
 # I have a lot of problems with cache. So ...
@@ -111,6 +111,7 @@ echo "Assumming OS is $OS"
 ####
 #### X11 stuff
 ####
+AC_ISC_POSIX		# to avoid a warning
 AC_PATH_X
 AC_PATH_XTRA
 
@@ -436,7 +437,7 @@ case $OS in
      # Add the -ldld flag 
      LIB_DLD=-ldld;;
    LINUX_ELF)
-     SH_CCFLAGS=''
+     SH_CCFLAGS='-fpic'
      SH_LDFLAGS='-shared -o'
      SH_LOADER='ld'
      SH_SUFFIX='so'