muller@src.dec.com (Eric Muller) (03/16/91)
[ For tcl-oriented readers: Modula-3 is a programming language
developed by Digital Equipment SRC and Olivetti. Send me a message
if you want more info, or join the comp.lang.modula3 newsgroup. ]
[ For Modula-3-oriented readers: tcl is a simple command language; you
can embed tcl interpreters in programs. There is also an associated X
toolkit. Send me a message if you want more info, or join the tcl
mailing list (tcl-request@sprite.berkeley.edu). ]
I played with tcl and being a Modula-3 fanatic I made a binding
interface. The shar file below contains TclC.i3 and Test.m3, a simple
test program. Test.m3 defines the "fact" command (implemented in
Modula-3) and repeatedly reads stdin to feed an interpreter and sends
its output to stdout.
This interface is a "raw" interface. It maps directly the C world. I
will probably work on a "nice" interface, using Text.T rather than
C.char_star and so on. Another thing would be a TclWriter.T, created on
top of another Wr.T; when tcl commands are fed into this TclWriter, it
writes the result of the evaluation on its underlying Wr.T.
Suggestions are welcome.
While doing this exercise, I discovered the following details about
the tcl man pages:
- Tcl_AddErrorInfo: returns void (instead of char*)
- Tcl_AppendResult: interp is an in argument (instead of out)
- Tcl_Eval: flags is an int (instead of char)
- Tcl_RecordAndEval: idem
- Tcl_GetInt: TCL_OK and TCL_ERRROR are in roman (instead of bold)
Thanks to John for this great little tool,
Eric.
---- Cut Here and unpack ----
#!/bin/sh
# This is a shell archive (shar 3.32)
# made 03/16/1991 06:28 UTC by muller@procope.pa.dec.com
# Source directory /flimflam/dlusers2/muller/src/Tk/m3
#
# existing files WILL be overwritten
#
# This shar contains:
# length mode name
# ------ ---------- ------------------------------------------
# 5976 -rw-r--r-- TclC.i3
# 1880 -rw-r--r-- Test.m3
#
if touch 2>&1 | fgrep 'amc' > /dev/null
then TOUCH=touch
else TOUCH=true
fi
# ============= TclC.i3 ==============
echo "x - extracting TclC.i3 (Text)"
sed 's/^X//' << 'SHAR_EOF' > TclC.i3 &&
X(* Copyright (C) 1991, Digital Equipment Corporation *)
X(* All rights reserved. *)
X
X(* Last modified on Sat Mar 16 07:37:04 1991 by muller *)
X
X
X(* This file has been derived from tcl.h, covered by the following copyright:
X
X * Copyright 1987, 1990 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies. The University of California
X * makes no representations about the suitability of this
X * software for any purpose. It is provided "as is" without
X * express or implied warranty.
X *)
X
XUNSAFE INTERFACE TclC;
X
XFROM Ctypes IMPORT char_star, int_star, int, char, double;
XIMPORT Word;
X
XCONST
X TCL_OK = 0;
X TCL_ERROR = 1;
X TCL_RETURN = 2;
X TCL_BREAK = 3;
X TCL_CONTINUE = 4;
X
X BRACKET_TERM = 1;
X NO_EVAL = -1;
X
X STATIC = 0;
X DYNAMIC = 1;
X VOLATILE = 2;
X
X TRACE_READS = 1;
X TRACE_WRITES = 2;
X TRACE_DELETES = 4;
X
X VARIABLE_UNDEFINED = 8;
X
X
XTYPE
X Argv = UNTRACED REF ARRAY [0..255] OF char_star;
X Interp = UNTRACED REF RECORD
X result: char_star; (* Points to result string returned by
X command. *)
X dynamic: int; (* Non-zero means result is dynamically-
X allocated and must be freed by Eval
X before executing the next command. *)
X errorLine: int; (* When TCL_ERROR is returned, this gives
X the line number within the command where
X the error occurred (1 means first line). *)
X END;
X
X ClientData = Word.T;
X
X
X
X<*EXTERNAL Tcl_AddErrorInfo *>
XPROCEDURE AddError (interp: Interp; message: char_star);
X
X<*EXTERNAL Tcl_AppendResult *>
XPROCEDURE AppendResult (interp: Interp; s1, s2, s3, s4, s5: char_star := NIL);
X
XTYPE
X CmdBuf = int_star;
X
X<*EXTERNAL Tcl_CreateCmdBuf *>
XPROCEDURE CreateCmdBuf (): CmdBuf;
X
X<*EXTERNAL Tcl_DeleteCmdBuf *>
XPROCEDURE DeleteCmdBuf (buffer: CmdBuf);
X
X<*EXTERNAL Tcl_AssembleCmd *>
XPROCEDURE AssembleCmd (buffer: CmdBuf; string: char_star): char_star;
X
X<*EXTERNAL Tcl_Backslash *>
XPROCEDURE Backslash (src: char_star; VAR count: int): char;
X
X<*EXTERNAL Tcl_Concat *>
XPROCEDURE Concat (argc: int; argv: Argv): char_star;
X
XTYPE
X CommandProc = PROCEDURE (clientData: ClientData;
X interp: Interp;
X argc: int;
X argv: Argv): int;
X
X DeleteProc = PROCEDURE (clientData: ClientData);
X
X<*EXTERNAL Tcl_CreateCommand *>
XPROCEDURE CreateCommand (interp: Interp;
X cmdName: char_star;
X proc: CommandProc;
X clientData: ClientData;
X deleteProc: DeleteProc);
X
X<*EXTERNAL Tcl_CreateInterp *>
XPROCEDURE CreateInterp (): Interp;
X
XTYPE
X TraceProc = PROCEDURE (clientData: ClientData;
X interp: Interp;
X level: int;
X command: char_star;
X cmdProc: CommandProc;
X cmdClientData: ClientData;
X argc: int;
X argv: Argv);
X Trace = int_star;
X
X<*EXTERNAL Tcl_CreateTrace *>
XPROCEDURE CreateTrace (interp: Interp;
X level: int;
X proc: TraceProc;
X clientData: ClientData): Trace;
X
X<*EXTERNAL Tcl_DeleteCommand *>
XPROCEDURE DeleteCommand (interp: Interp; cmdName: char_star);
X
X<*EXTERNAL Tcl_DeleteInterp *>
XPROCEDURE DeleteInterp (interp: Interp);
X
X<*EXTERNAL Tcl_DeleteTrace *>
XPROCEDURE DeleteTrace (interp: Interp; trace: Trace);
X
X<*EXTERNAL Tcl_Eval *>
XPROCEDURE Eval (interp: Interp;
X cmd: char_star;
X flags: int;
X termPtr: Argv): int;
X
X<*EXTERNAL Tcl_Expr *>
XPROCEDURE Expr (interp: Interp; string: char_star; VAR value: int): int;
X
X<*EXTERNAL Tcl_GetInt *>
XPROCEDURE GetInt (interp: Interp; string: char_star; VAR val: int): int;
X
X<*EXTERNAL Tcl_GetDouble *>
XPROCEDURE GetDouble (interp: Interp; string: char_star; VAR val: double): int;
X
X<*EXTERNAL Tcl_GetBoolean *>
XPROCEDURE GetBoolean (interp: Interp; string: char_star; VAR value: int): int;
X
X<*EXTERNAL Tcl_GetVar *>
XPROCEDURE GetVar (interp: Interp; varName: char_star; global: int): char_star;
X
X<*EXTERNAL Tcl_Merge *>
XPROCEDURE Merge (argc: int; argv: Argv): char_star;
X
X<*EXTERNAL Tcl_ParseVar *>
XPROCEDURE ParseVar (interp: Interp;
X string: char_star;
X term: Argv): char_star;
X
X<*EXTERNAL Tcl_RecordAndEval *>
XPROCEDURE RecordAndEval (interp: Interp; cmd: char_star; flags: int): int;
X
X<*EXTERNAL Tcl_Return *>
XPROCEDURE Return (interp: Interp; string: char_star; status: int);
X
X<*EXTERNAL Tcl_SetVar *>
XPROCEDURE SetVar (interp: Interp; varName, newValue: char_star; global: int);
X
X<*EXTERNAL Tcl_SplitList *>
XPROCEDURE SplitList (interp: Interp;
X list: char_star;
X VAR argc: int;
X VAR argv: Argv): int;
X
X<*EXTERNAL Tcl_StringMatch *>
XPROCEDURE StringMatch (string, pattern: char_star): int;
X
X<*EXTERNAL Tcl_TildeSubst *>
XPROCEDURE TildeSubst (interp: Interp; name: char_star): char_star;
X
XTYPE
X VarTraceProc = PROCEDURE (clientData: ClientData;
X interp: Interp;
X varName: char_star;
X global, flags: int;
X oldValue, newValue: char_star): char_star;
X
X<*EXTERNAL Tcl_TraceVar *>
XPROCEDURE TraceVar (interp: Interp;
X varName: char_star;
X global, flags: int;
X proc: VarTraceProc;
X clientData: ClientData): int;
X
X<*EXTERNAL Tcl_UnTraceVar *>
XPROCEDURE UnTraceVar (interp: Interp; varName: char_star; global: int);
X
X<*EXTERNAL Tcl_VarTraceInfo *>
XPROCEDURE VarTraceInfo (interp: Interp;
X varName: char_star;
X global: int;
X VAR proc: VarTraceProc;
X VAR clientData: ClientData): int;
X
XEND TclC.
SHAR_EOF
$TOUCH -am 0315222891 TclC.i3 &&
chmod 0644 TclC.i3 ||
echo "restore of TclC.i3 failed"
set `wc -c TclC.i3`;Wc_c=$1
if test "$Wc_c" != "5976"; then
echo original size 5976, current size $Wc_c
fi
# ============= Test.m3 ==============
echo "x - extracting Test.m3 (Text)"
sed 's/^X//' << 'SHAR_EOF' > Test.m3 &&
X(* Copyright (C) 1991, Digital Equipment Corporation *)
X(* All rights reserved. *)
X
X
XUNSAFE MODULE Test EXPORTS Main;
X
XIMPORT TclC;
XIMPORT Rd, Wr, Stdio, Fmt;
XFROM M3toC IMPORT TtoS, CopyTtoS, CopyStoT;
XFROM Ctypes IMPORT int, char_star;
X
XPROCEDURE FactCmd (<*UNUSED*> clientData: TclC.ClientData;
X interp: TclC.Interp;
X argc: int;
X argv: TclC.Argv): int =
X BEGIN
X IF argc # 2 THEN
X interp.result := TtoS ("fact has exactly one argument");
X RETURN TclC.TCL_ERROR;
X ELSE
X VAR i: INTEGER; BEGIN
X IF TclC.GetInt (interp, argv[1], i) = TclC.TCL_ERROR THEN
X RETURN TclC.TCL_ERROR; END;
X interp.result := CopyTtoS (Fmt.Int (Fact (i)));
X RETURN TclC.TCL_OK; END; END;
X END FactCmd;
X
XPROCEDURE Fact (i: INTEGER): INTEGER =
X BEGIN
X IF i = 1 THEN
X RETURN 1;
X ELSE
X RETURN i * Fact (i - 1); END;
X END Fact;
X
X
XVAR
X i: TclC.Interp;
X buf: TclC.CmdBuf;
X s: char_star;
X status: int;
X
XBEGIN
X i := TclC.CreateInterp ();
X TclC.CreateCommand (i, TtoS ("fact"), FactCmd, 0, NIL);
X buf := TclC.CreateCmdBuf ();
X
X TRY
X LOOP
X s := TclC.AssembleCmd (buf, TtoS (Rd.GetLine (Stdio.stdin) & "\n"));
X IF s # NIL THEN
X status := TclC.Eval (i, s, 0, NIL);
X CASE status OF
X | TclC.TCL_OK =>
X Wr.PutText (Stdio.stderr, "-> " & CopyStoT (i.result) & "\n");
X | TclC.TCL_ERROR =>
X Wr.PutText (Stdio.stderr, "error: " & CopyStoT (i.result) & "\n");
X ELSE
X Wr.PutText (Stdio.stderr, "TclC.Eval returned with code = "
X & Fmt.Int (status) & "\n");
X END; END; END;
X EXCEPT
X | Rd.EndOfFile => END;
X
X TclC.DeleteCmdBuf (buf);
X TclC.DeleteInterp (i);
XEND Test.
SHAR_EOF
$TOUCH -am 0315222691 Test.m3 &&
chmod 0644 Test.m3 ||
echo "restore of Test.m3 failed"
set `wc -c Test.m3`;Wc_c=$1
if test "$Wc_c" != "1880"; then
echo original size 1880, current size $Wc_c
fi
exit 0