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

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

Binary file not shown.

File diff suppressed because it is too large Load Diff

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

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}

Binary file not shown.

File diff suppressed because it is too large Load Diff

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}

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.

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.

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

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

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

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)

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

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;

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)

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

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

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

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

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

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

View File