conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Commit of 3.99.2 version

This commit is contained in:
Erick Gallesio 1998-06-09 13:07:40 +02:00
parent 3c98caa84e
commit dd57fe2b2a
56 changed files with 11456 additions and 8166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
CHANGES
View File

@ -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
-----------------------

111
ChangeLog
View File

@ -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

BIN
Doc/Isotas96/Isotas96.dvi
View File

Binary file not shown.

7742
Doc/Isotas96/Isotas96.ps
View File

File diff suppressed because it is too large Load Diff

14
Doc/Reference/Appendix-E.tex
View File

@ -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}}

81
Doc/Reference/Reference1.tex
View File

@ -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
next \var{obj}.
\item \tilda{}a or \tilda{}A is replaced by the printed representation
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}

BIN
Doc/Reference/manual.dvi
View File

Binary file not shown.

10004
Doc/Reference/manual.ps
View File

File diff suppressed because it is too large Load Diff

4
Doc/Reference/manual.tex
View File

@ -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}

113
Doc/Tcl93/Tcl93.log
View File

@ -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.

37
Extensions/%README
View File

@ -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
STk Interpreter" provided with the package.
For more informations on extension building, read the document
"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.

10
Extensions/Makefile.in
View File

@ -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

99
Extensions/Makefile.sample
View File

@ -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 *~

4
Extensions/configure vendored
View File

@ -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

2
Extensions/configure.in
View File

@ -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)

201
Extensions/html.c
View File

@ -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')) {
ch = tolower(c);
Tcl_DStringAppend(&dStr1, &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);
}
while ((c = Getc(f)) != EOF && (c != '>')) {
ch = c;
Tcl_DStringAppend(&dStr2, &ch, 1);
}
}
if (Tcl_DStringValue(&dStr1)[0] == '\0')
z = STk_makestring("<>");
else
if (Tcl_DStringValue(&dStr1)[0]=='/' && Tcl_DStringValue(&dStr1)[1] == '\0')
z = STk_makestring("</>");
else
z = Cons(STk_makestring(Tcl_DStringValue(&dStr1)),
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));
}
if (Tcl_DStringValue(&dStr1)[0] == '\0')
z = STk_makestring("<>");
else
if (Tcl_DStringValue(&dStr1)[0]=='/' && Tcl_DStringValue(&dStr1)[1] == '\0')
z = STk_makestring("</>");
else
z = Cons(STk_makestring(Tcl_DStringValue(&dStr1)),
STk_makestring(Tcl_DStringValue(&dStr2)));
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:next-token", tc_subr_1, STk_html_next_token);
STk_add_new_primitive("%html:clean-spaces", tc_subr_2, html_clean_spaces);
STk_add_new_primitive("%html:next-token", tc_subr_1, html_next_token);
return UNDEFINED;
}

81
Extensions/process.c
View File

@ -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 {
/* process has terminated and we must save this information */
PROCESS(process)->exited = TRUE;
PROCESS(process)->exit_status = info;
return FALSE;
}
else
if (res == PROCPID(process)) {
/* process has terminated and we must save this information */
PROCESS(process)->exited = TRUE;
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,
"run-process: string expected. It was", CAR(l));
cannot_run(pipes, argv_start, "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,
"run-process: boolean expected. It was", CAR(l));
cannot_run(pipes, argv_start, "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);
PROCESS(process)->exited = TRUE;
return (ret == 0) ? Ntruth : Truth;
int info, res;
res = waitpid(PROCPID(process), &info, 0);
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 (NINTEGERP(signal)) Err("process-send-signal: bad integer", signal);
if (NPROCESSP(process)) Serror("bad process", process);
if (NINTEGERP(signal)) Serror("bad integer", signal);
kill(PROCPID(process), STk_integer_value(signal));
return UNDEFINED;

14
Extensions/sregexp.c
View File

@ -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)
Err("string->regexp: error compiling regexp", obj);
if (NSTRINGP (obj)) Serror("not a string", 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)) {

80
Extensions/stk-genmake.in Normal file
View File

@ -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)

8
INSTALL
View File

@ -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
variable is correctly set). When this is done, enter the following line
When you have the STk prompt (and if your DISPLAY variable is correctly set),
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
will leave the scheme interpreter. A more complete demo can be obtained with:
This will display an Hello world button. Clicking on it will leave the scheme
interpreter. A more complete demo can be obtained with:
$ make demos

8
Lib/help.stk
View File

@ -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")

17
Lib/init.stk
View File

@ -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))
(call-with-values (lambda () result)
(lambda l
(for-each (lambda (x) (write* x) (newline)) l))))))
(if (eqv? result (make-undefined))
(when *last-defined*
(format #t "~S\n" *last-defined*)
(set! *last-defined* #f))
(call-with-values (lambda () result)
(lambda l
(for-each (lambda (x) (write* x) (newline)) l))))))

16
Lib/tk-init.stk
View File

@ -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

6
Lib/trace.stk
View File

@ -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))

4
Lib/www-browser.stklos
View File

@ -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

6
Makefile.in
View File

@ -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)

145
STk.prj
View File

@ -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)
(Parent-Version STk 3.99.1 21)
(Project-Version STk 3.99.2 7)
(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 (STk/K/30_configure 1.1.1.1 755))
(VERSION (STk/K/31_VERSION 1.3 644))
(configure.in (STk/K/29_configure. 1.1.1.4 644))
(configure (STk/K/30_configure 1.1.1.4 755))
(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))
(INSTALL (STk/K/35_INSTALL 1.3 644))
(ChangeLog (STk/K/36_ChangeLog 1.20.1.5 644))
(Makefile.in (STk/K/33_Makefile.i 1.3.1.6 644))
(INSTALL (STk/K/35_INSTALL 1.4 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.ps (STk/N/20_Isotas96.p 1.6 644))
(Doc/Isotas96/Isotas96.dvi (STk/N/19_Isotas96.d 1.7 644) :no-keywords)
(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.ps (STk/P/10_manual.ps 1.7 644) :no-keywords)
(Doc/Reference/manual.tex (STk/P/11_manual.tex 1.3 644))
(Doc/Reference/manual.dvi (STk/P/9_manual.dvi 1.9 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.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/Makefile.in (STk/P/33_Makefile.i 1.2 644))
(Extensions/Makefile.sample (STk/P/34_Makefile.s 1.1 444))
(Extensions/configure (STk/P/35_configure 1.1 755))
(Extensions/configure.in (STk/P/36_configure. 1.1 444))
(Extensions/%README (STk/P/32_%README 1.2 644))
(Extensions/Makefile.in (STk/P/33_Makefile.i 1.3 644))
(Extensions/configure (STk/P/35_configure 1.2 755))
(Extensions/configure.in (STk/P/36_configure. 1.2 644))
(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-meta.stklos (STk/W/48_Tk-meta.st 1.8 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.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/address.c (STk/X/6_address.c 1.1 444))
(Src/argv.c (STk/X/7_argv.c 1.1 444))
(Src/boolean.c (STk/X/8_boolean.c 1.1 444))
(Src/char.c (STk/X/9_char.c 1.1 444))
(Src/Makefile.in (STk/X/5_Makefile.i 1.7 644))
(Src/address.c (STk/X/6_address.c 1.1 644))
(Src/argv.c (STk/X/7_argv.c 1.2 644))
(Src/boolean.c (STk/X/8_boolean.c 1.1 644))
(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/dump.c (STk/X/14_dump.c 1.1 444))
(Src/dynload.c (STk/X/15_dynload.c 1.2 644))
(Src/dummy.c (STk/X/13_dummy.c 1.1 644))
(Src/dump.c (STk/X/14_dump.c 1.1 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/list.c (STk/X/25_list.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 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/read.c (STk/X/35_read.c 1.3 644))
(Src/promise.c (STk/X/34_promise.c 1.1 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.h (STk/X/42_stk.h 1.12 644))
(Src/stklos.c (STk/X/43_stklos.c 1.13 644))
(Src/stk.c (STk/X/41_stk.c 1.1 644))
(Src/stk.h (STk/X/42_stk.h 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/syntax.c (STk/X/47_syntax.c 1.2 444))
(Src/tcl-glue.c (STk/X/48_tcl-glue.c 1.5 644))
(Src/symbol.c (STk/X/46_symbol.c 1.1 644))
(Src/syntax.c (STk/X/47_syntax.c 1.3 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/toplevel.c (STk/Y/6_toplevel.c 1.5 644))
(Src/trace.c (STk/Y/7_trace.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.6 644))
(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/wstk.c (STk/Y/12_wstk.c 1.1 444))
(Src/vector.c (STk/Y/11_vector.c 1.1 644))
(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))

10
STklos/Tk/Basics.stklos
View File

@ -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

7
STklos/Tk/Tk-classes.stklos
View File

@ -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>)

11
STklos/Tk/Tk-meta.stklos
View File

@ -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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;

30
STklos/stklos.stk
View File

@ -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))
(m (list->set (map slot-definition-name slots))))
(when (< (length m) (length slots))
(error "define-class: bad list of slots ~S" slots))
(when (< (length s) (length supers))
(error "define-class: bad list of superclasses ~S" supers)))
(let ((tmp1 (find-duplicate supers))
(tmp2 (find-duplicate (map slot-definition-name slots))))
(when tmp1
(error "define-class: super class ~S is duplicate in class ~S" tmp1 name))
(when tmp2
(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))

4
Src/Makefile.in
View File

@ -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

7
Src/argv.c
View File

@ -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)
{

58
Src/dynload.c
View File

@ -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)
Serror("cannot open object file", str);
cache_files = Cons(str,
Cons(MAKE_STAT_PTR(handle), cache_files));
if ((handle=(void *) dlopen(path, DYN_FLAG)) == NULL)
Serror("cannot open object file", str);
cache_files = Cons(str, 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

6
Src/error.c
View File

@ -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();

9
Src/io.c
View File

@ -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

6
Src/module.c
View File

@ -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;
}

103
Src/port.c
View File

@ -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))) {
sprintf(buff, "%s: bad port", who);
Err(buff, port);
}
if (PORT_FLAGS(port) & PORT_CLOSED) {
sprintf(buff, "%s: port is closed", who);
Err(buff, port);
}
if (!(INP(port) || OUTP(port))) Serror("bad port", port);
if (PORT_FLAGS(port) & PORT_CLOSED) Serror("port is closed", port);
if ((mode & F_READ) && INP(port)) return port; /* not else. It can be both */
if ((mode & F_WRITE) && OUTP(port)) return port;
Error:
sprintf(buff, "%s: bad port", who);
Err(buff, port);
Serror("bad port", 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 (!STk_is_thunk(thunk)) Err("with-input-from-file: bad thunk", thunk);
if (NSTRINGP(string)) Serror("bad string", string);
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);
if (!STk_is_thunk(thunk)) Err("with-output-to-file: bad thunk", thunk);
ENTER_PRIMITIVE("with-output-to-file");
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);
port = verify_port("write-char", port, F_WRITE);
ENTER_PRIMITIVE("write-char");
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);
if (NSTRINGP(fmt)) Err("format: bad format string", fmt);
verify_port(proc_name, port, F_WRITE);
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) {
STk_print(CAR(l),
port,
(tolower(*p) == 's')? WRT_MODE: DSP_MODE);
l = CDR(l);
}
else Err("format: too much ~ in format string", l);
case 'a': if (len-- <= 0) goto TooMuch;
STk_print(CAR(l), port, DSP_MODE);
l = CDR(l);
continue;
case 'S':
case 's': if (len-- <= 0) goto TooMuch;
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 '\r': i--; continue;
case EOF: if (i == 0) { free(buff); return STk_eof_object; }/* NO BREAK */
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;

205
Src/print.c
View File

@ -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);
if (!entry) panic("Internal error within STk_print_label");
val = (SCM) Tcl_GetHashValue(entry);
if (INTEGERP(val)) {
Tcl_SetHashValue(entry, Cons(val, val));
return INTEGER(val);
static void print_cycle(SCM exp, SCM port)
{
SCM value, tmp;
if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
if (INTEGERP(value = CDR(tmp))) {
char buffer[50];
sprintf(buffer, "#%d#", INTEGER(value));
Puts(buffer, PORT_FILE(port));
return;
}
}
return -1;
}
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;
/* This is not a cycle. Do a normal print */
pass2(exp, port);
}
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) {
sprintf(buffer, "#%d=", label);
Puts(buffer, f);
}
Putc('(', f);
Putc('(', f);
for ( ; ; ) {
if ((label = get_use_label(CAR(exp))) >= 0) {
sprintf(buffer, "#%d#", label);
Puts(buffer, f);
}
else pass2(CAR(exp), port);
exp = CDR(exp);
print_cycle(CAR(exp), port);
if (NULLP(exp)) break;
if ((label = get_use_label(exp)) >= 0) {
sprintf(buffer, " . #%d#", label);
Puts(buffer, f);
break;
}
if (NCONSP(exp)) {
Puts(" . ", f);
pass2(exp, port);
break;
if (NULLP(exp=CDR(exp))) break;
if ((tmp = STk_assv(exp, cycles)) != Ntruth) {
value = CDR(tmp);
if (NCONSP(exp) || value == Truth || INTEGERP(value)) {
/* either ". X" or ". #0=(...)" or ". #0#" */
Puts(" . ", f);
print_cycle(exp, port);
break;
}
}
Putc(' ', f);
}
Putc(')', f);
}
static void printvector_star(SCM exp, SCM port)
{
FILE *f = PORT_FILE(port);
char buffer[50];
int i, label, len = VECTSIZE(exp);;
if ((label = get_def_label(exp)) >= 0) {
sprintf(buffer, "#%d=", label);
Puts(buffer, f);
}
Puts("#(", f);
int j, n = exp->storage_as.vector.dim;
for (i = 0; i < len; i++) {
SCM tmp = VECT(exp)[i];
if ((label = get_use_label(tmp)) >= 0) {
sprintf(buffer, "#%d#", label);
Puts(buffer, f);
}
else pass2(tmp, port);
if (i < len-1) Putc(' ', f);
Puts("#(", f);
for(j=0; j < n; j++) {
print_cycle(VECT(exp)[j], port);
if ((j + 1) < n) Putc(' ', f);
}
Putc(')', f);
}
static void pass1(SCM exp)
{
Tcl_HashEntry *entry;
int new;
SCM tmp;
Top:
if (NCONSP(exp) && NVECTORP(exp)) return;
entry = Tcl_CreateHashEntry(&cycle_table, (char *) exp, &new);
if (new) {
/* We have never seen this cell */
Tcl_SetHashValue(entry, Truth);
switch (TYPE(exp)) {
case tc_cons: pass1(CAR(exp)); pass1(CDR(exp)); break;
case tc_vector: {
int i, len = VECTSIZE(exp);
for (i = 0; i < len; i++) pass1(VECT(exp)[i]);
}
break;
if ((tmp = STk_assv(exp, cycles)) == Ntruth) {
/* We have never seen this cell so far */
cycles = Cons(Cons(exp, Ntruth), cycles);
if (CONSP(exp)) { /* it's a cons */
pass1(CAR(exp));
exp = CDR(exp);
goto Top;
}
}
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);
if (val == Truth)
/* No label has been assigned to this cell. Provide one */
Tcl_SetHashValue(entry, (char *) STk_makeinteger(index_label++));
/* This item was already seen. Note that this is the second time */
CDR(tmp) = Truth;
}
}
static SCM pass2(SCM exp, SCM port)
{
FILE *f = PORT_FILE(port);
switch (TYPE(exp)) {
case tc_cons: printlist_star(exp, port); break;
case tc_vector: printvector_star(exp, port); break;
default: STk_print(exp, port, WRT_MODE);
static void pass2(SCM exp, SCM port)
{
if (NCONSP(exp) && NVECTORP(exp))
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))
return STk_print(exp, port, WRT_MODE);
Tcl_InitHashTable(&cycle_table, TCL_ONE_WORD_KEYS);
if (NCONSP(exp) && NVECTORP(exp)) return STk_print(exp, port, WRT_MODE);
if (cycles == NULL) STk_gc_protect(&cycles);
cycles = NIL;
index_label = 0;
pass1(exp);
pass2(exp, port);
pass1(exp); pass2(exp, port);
return UNDEFINED;
}

152
Src/read.c
View File

@ -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);
}

11
Src/slib.c
View File

@ -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

8
Src/stk.h
View File

@ -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

9
Src/stklos.c
View File

@ -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 (NINSTANCEP(obj)) Serror("bad object", obj);
if (NCLASSP(classe)) Serror("bad class", classe);
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;
}

5
Src/syntax.c
View File

@ -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);
}

6
Src/tcl-glue.c
View File

@ -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);
}

4
Src/tcl-lib.c
View File

@ -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];

21
Src/toplevel.c
View File

@ -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)

14
Src/wstk.c
View File

@ -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));

5
Tcl/Makefile.in
View File

@ -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 \
tclNotify.o @LIBOBJS@
OBJ = panic.o tclHash.o tclGet.o regexp.o tclUtil.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

4
Tcl/tcl.h
View File

@ -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

2
Tcl/tclEvent.c
View File

@ -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

6
Tk/unix/tkUnixSend.c
View File

@ -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);

32
Utils/STk.spec
View File

@ -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.1/Help
/usr/local/lib/stk/3.99.1/Images
/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/stk
/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/snow
/usr/local/lib/stk/3.99.1/Linux-2.X-ix86/*.so
/usr/local/lib/stk/3.99.1/STk
/usr/local/lib/stk/3.99.1/include
/usr/local/lib/stk/3.99.1/man
/usr/local/bin/stk-3.99.1
/usr/local/bin/snow-3.99.1
/usr/local/lib/stk/3.99.2/Demos
/usr/local/lib/stk/3.99.2/Help
/usr/local/lib/stk/3.99.2/Images
/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/stk
/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/snow
/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/*.so
/usr/local/lib/stk/3.99.2/STk
/usr/local/lib/stk/3.99.2/include
/usr/local/lib/stk/3.99.2/man
/usr/local/bin/stk-3.99.2
/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.1/Linux-2.X-ix86/Libs
/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/Config
/usr/local/lib/stk/3.99.2/Linux-2.X-ix86/Libs

2
VERSION
View File

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

52
configure vendored
View File

@ -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'

5
configure.in
View File

@ -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'