DNA.

wyrmwif

Version.

1.2.9

Namespace.

::wyrm ::wyrm::wif

Command.

::wyrm::setp ::wyrm::lambda ::wyrm::block ::wyrm::try

Language.

Manpage.

Manpage.

Manpage.

Manpage.

Manpage.

Testbase.

Import.

Object.: wyrm-bytes; wyrm-data; wyrm-huff; wyrm-io; wyrm-pref; kwbase64

Export.

Implementation.: wyrmwif.c
Interface.: wyrmwif.h
Object.: wyrmwif.o
Package.: wyrmwif.dylib
System.: wyrmwif.sys; wyrmwif.sys

Wyrmwif Tcl Extensions

Sections.: Wyrmwif Types and Utilities; Typedefs; Memory allocation; String operators; Utility commands; Wyrmwif package

Make.

Object.

compile -c -o [
  export object
] [
  export implementation
] -- -list [export interface] $include/unix/$base.sys

Package.

compile -ld -o [export package] -list [import object] [export object]

Prelude.

file mkdir $obj
foreach var {debug test opt} {
  if {![info exists option($var)]} {set option($var) 0}
}
if {!$option(debug) && !$option(opt)} {set option(debug) 1}
if {$option(debug)} {set option(test) 1}
proc compile {args} {
  global option include
  set remove ""
  switch $::tcl_platform(os) {
    IRIX64 {
      set command "gcc"
    }
    default {
      set command "cc"
    }
  }
  set d 0; set target ""; set depends {}
  set version VERSION
  set postnuke ""
  while {[llength $args]} {
    set arg [lindex $args 0]; set args [lrange $args 1 end]
    switch -glob -- $arg {
      -V {
        set version [lindex $args 0]; set args [lrange $args 1 end]
      }
      -c - -cc {
        set postnuke " 2>&1 | (grep -v 'discards qualifiers from pointer target type'; exit 0)"
        switch $::tcl_platform(os) {
          Darwin {
append command " -I$include -I$include/Darwin -I$include/unix -fno-common"
append command " -I/System/Library/Frameworks/Tcl.framework/Versions/8.4/Headers"
append command " -I~/Library/Frameworks/Tcl.framework/Versions/8.4/Headers"
append command " -I/Library/Frameworks/Tcl.framework/Versions/8.4/Headers"
            append command " -Wno-multichar -Wno-cast-qual"
          }
          Linux {
            append command " -I$include -I$include/Linux -I$include/unix"
            append command " -Wno-multichar -Wno-cast-qual"
          }
          IRIX64 {
            append command " -I$include -I$include/IRIX64 -I$include/unix"
            set postnuke ""
          }
          default {
            error "do not how to compile -c for $::tcl_platform(os)"
          }
        }
        append command " '-D${version}=\"[control ver]\"'"
        if {$option(debug)} {append command " -g -DDEBUG -DTCL_MEM_DEBUG"}
        if {$option(opt)} {append command " -O"}
        if {$option(test)} {append command " -DTESTING"}
        if {[string equal $arg -c]} {append command " -c"}
      }
      -ld {
        switch $::tcl_platform(os) {
          Darwin {
            append command " -dynamiclib -flat_namespace -undefined suppress"
          }
          Linux {
            append command " -pipe -shared"
          }
          IRIX64 {
            append command " -shared"
          }
          default {
            error "do not how to compile -ld for $::tcl_platform(os)"
          }
        }
      }
      -exec {
        switch $::tcl_platform(os) {
          Darwin {
            append command " -prebind -Wl,-no_arch_warnings -lpthread"
            append command " -framework Tcl -framework CoreFoundation"
          }
          Linux {
            append command " -pipe -L/usr/local/lib -ltcl8.4"
          }
          IRIX64 {
            append command " /usr/lib/libtcl8.4.so"
          }
          default {
            error "do not how to compile -exec for $::tcl_platform(os)"
          }
        }
      }
      -o {
        set target [lindex $args 0]; set args [lrange $args 1 end]
        set remove "-rm -f $target\n"
        append command " -o $target"
      }
      -- {
        set d 1
      }
      -list {
        set list [lindex $args 0]; set args [lrange $args 1 end]
        foreach e $list {
          lappend depends $e
          if {!$d} {append command " $e"}
        }
      }
      '-* {
        append command " $arg"
      }
      -* {
        append command " $arg"
      }
      +* {
        append command " [string range $arg 1 end]"
      }
      default {
        lappend depends $arg
        if {!$d} {append command " $arg"}
      }
    }
  }
  rule [list $target] $depends "
    $remove$command$postnuke
  "
}

Script.

rule wyrmwif.package $so/wyrmwif[info sharedlibextension]
rule wyrmwif.test [list \
    pkgIndex.tcl \
    $test/wyrmwif.test.html \
    $test/wyrm-io.test.html \
    $test/wyrm-bytes.test.html \
    $test/wyrm-data.test.html \
    $test/wyrm-pref.test.html \
    $test/kwbase64.test.html \
    $test/wyrm-huff.test.html \
]
rule clean :: {} "
  -rm [export object] [import object]
  -rm $test/wyrmwif.TESTING
  -rm $test/wyrm-bytes.TESTING
  -rm $test/wyrm-data.TESTING
  -rm $test/wyrm-huff.TESTING
  -rm $test/wyrm-io.TESTING
  -rm $test/wyrm-pref.TESTING
  -rm $test/kwbase64.TESTING
"
rule shar {pkgIndex.tcl executables} {
  -rm -rf wyrmwif
  -rm -rf wyrmwif.tar
  -rm -rf wyrmwif.tar.gz
  -rm -rf wyrmwif.uu
  tar cf wyrmwif.tar \
      bin/ribosome build-cycle checkpoints/mods decks *.dna dna.dtd index.html \
      $$(find html img include lib/make source test ! -name '.*' ! -name '*.o' -type f -print)
  gzip wyrmwif.tar
  uuencode wyrmwif.tar.gz wyrmwif.tar.gz >wyrmwif.uu
  echo >wyrmwif.shar '#!/bin/sh'
  echo >>wyrmwif.shar 'echo ____________________________________________________________________'
  echo >>wyrmwif.shar 'owd=$$(pwd)'
  echo >>wyrmwif.shar 'if [ $$# -gt 1 ]'
  echo >>wyrmwif.shar '  then'
  echo >>wyrmwif.shar '    echo too many parameters: $$*'
  echo >>wyrmwif.shar '    exit 1'
  echo >>wyrmwif.shar 'elif [ $$# -eq 1 ]'
  echo >>wyrmwif.shar '  then'
  echo >>wyrmwif.shar '    nwd="$$1"'
  echo >>wyrmwif.shar 'else'
  echo >>wyrmwif.shar '    nwd=wyrmwif'
  echo >>wyrmwif.shar 'fi'
  echo >>wyrmwif.shar echo Wyrmwif installer.
  echo >>wyrmwif.shar echo Built: $$(date).
  echo >>wyrmwif.shar 'echo Source: $$owd/$$0'
  echo >>wyrmwif.shar 'installer () {'
  echo >>wyrmwif.shar '  echo Install: $$nwd'
  echo >>wyrmwif.shar '  mkdir -p $$nwd'
  echo >>wyrmwif.shar '  cd $$nwd'
  echo >>wyrmwif.shar '  nwd=$$(pwd)'
  echo >>wyrmwif.shar '  gunzip $$owd/wyrmwif.tar.gz'
  echo >>wyrmwif.shar '  tar xf $$owd/wyrmwif.tar'
  echo >>wyrmwif.shar '  rm $$owd/wyrmwif.tar'
  echo >>wyrmwif.shar '  chmod a+wrx bin/ribosome'
  echo >>wyrmwif.shar '  bin/ribosome -bootstrap'
  echo >>wyrmwif.shar '  echo "TCLLIBPATH=$$TCLLIBPATH $$nwd/lib $$nwd/lib/$$(uname)"'
  echo >>wyrmwif.shar '  echo "PATH=$$PATH:$$nwd/bin:$$nwd/bin/$$(uname)"'
  echo >>wyrmwif.shar '  echo ____________________________________________________________________'
  echo >>wyrmwif.shar '  exit 0'
  echo >>wyrmwif.shar '}'
  echo >>wyrmwif.shar "uudecode <<':eof'; installer"
  cat <wyrmwif.uu >>wyrmwif.shar
  echo >>wyrmwif.shar :eof
  -rm wyrmwif.uu
  -rm wyrmwif.tar.gz
  -chmod a+rwx wyrmwif.shar
  #-rm *.dna
}

1 :: Define frequently used types and #defines that do not really fit anywhere else, and few utility commands.

Wyrmwif Tcl extensions. For non-profit uses only, provided this copyright is preserved on all copies, this work may be freely copied, modified, redistributed, compiled, and incorporated in other works. This work is distributed with no warranty of any kind; no author or distributor accepts any responsibility for the consequences of using it, or for whether it serves any particular purpose or works at all, unless he or she says so in writing.

Wyrmwif Types and Utilities

top
2. wyrmwif (4WY) :: NAME wyrmwif — Wyrmwif types and utilities. synopsis <wyrmwif (4WY) Synopsis> Private <wyrmwif (4WY) Private Synopsis> description <wyrmwif.h> <wyrmwif (4WY) Description>	^
Manpage wyrmwif (4WY)

section top
3. wyrmwif.h :: The header file defines types and general utilities that really do not fit anywhere else more specific. #ifndef WYRM_WIF_H #define WYRM_WIF_H // wyrmwif.dna - Copyright (C) 2002 SM Ryan. All rights reserved.' #include <stdlib.h> #include <tcl.h> #include "wyrmwif.sys" <General typedefs> <Memory allocation declarations> <String operator declarations> <extern declarations> #endif	^
Referenced at: 2. Interface wyrmwif.h

section top
4. wyrmwif.c :: static const char COPYRIGHT[] = "wyrmwif.dna - Copyright (C) 2002 SM Ryan. All rights reserved."; #include "wyrmwif.h" <Memory allocation routines> <String operators> <lambda (1WY)> <setp (1WY)> <try (1WY)> <qutil (1WY)>	^
Definition continued at: 61, 64, 68. Implementation wyrmwif.c

section top
5. mac/wyrmwif.sys :: For Macintosh, include the system types and define the host/network byte orders (which are all identities). #include "Types.h" #define htonl(x) (x) #define htons(x) (x) #define ntohl(x) (x) #define ntohs(x) (x)	^
System wyrmwif.sys

section top
6. unix/wyrmwif.sys :: For Unix, include the system types and define the bool values. The host/network byte orders are in <netinet/in.h>. enum {false,true}; #include <sys/types.h> #include <netinet/in.h>	^
System wyrmwif.sys

7 wyrmwif (4WY) Synopsis

8 General typedefs

Typedefs

7. wyrmwif (4WY) Synopsis ::

#include "wyrmwif.h"

typedef chars;
typedef ptr;
typedef bool;
typedef byte,bytes;
typedef Intr;
typedef Obj,ObjV;

8. General typedefs ::

type Char—Unicode character.

typedef Tcl_UniChar Char;

9. General typedefs ::

type Chars—Pointer to unicode or unicode array (string).

typedef Tcl_UniChar *Chars;

10. General typedefs ::

type bool—Booleans.

bool true—Boolean constan value.

Enumeration. 1

bool false—Boolean constan value.

Enumeration. 0

typedef unsigned char bool;

11. General typedefs ::

type byte—Smallest addressable unsigned data.

typedef unsigned char byte;

12. General typedefs ::

type bytes—Pointer to byte or byte array.

typedef unsigned char *bytes;

13. General typedefs ::

type chars—Pointer to char or char array (string).

typedef char *chars;

14. General typedefs ::

type ptr—Pointer to void.

typedef void *ptr;

15. General typedefs ::

type Intr—Pointer to Tcl_Interp.

typedef Tcl_Interp *Intr;

16. General typedefs ::

type Obj—Pointer to Tcl_Obj.

typedef Tcl_Obj *Obj;

17. General typedefs ::

type ObjV—Tcl_Obj vector as a command argument list.

typedef Tcl_Obj *CONST ObjV[];

18 wyrmwif (4WY) Synopsis

19 wyrmwif (4WY) Private Synopsis

20 wyrmwif (4WY) Description

21 Memory allocation declarations

36 Memory allocation routines

Memory allocation

18. wyrmwif (4WY) Synopsis ::

ptr heap(typedef T);
ptr nheap(int n,typedef T);
ptr reheap(int n,typedef T,ptr p);
ptr allocate(int n);
ptr reallocate(int n,ptr p);
void dispose(ptr p);
ptr zero(int n,typedef T,ptr p);
ptr memcopy(int n,typedef T,ptr dd,ptr ss);
Obj incr(Obj p);
bool decr(Obj p);

19. wyrmwif (4WY) Private Synopsis :: The follow functions are also defined, but they should not be used directly.

Obj wyrm_incr(Obj p);
Obj wyrm_incrd(Obj p,chars file,int line);
bool wyrm_decr(Obj p);
bool wyrm_decrd(Obj p,chars file,int line);

20. wyrmwif (4WY) Description :: This interface, placed on top of ckalloc, ckrealloc, and ckfree Tcl_IncrRefCount, and Tcl_DecrRefCount, is more convenient in dealing with NULL, sizeof arithmetic, and similar issues.

heap allocates one variable of type T; nheap allocates an array. reheap reallocates (or allocates anew if p is NULL) an array. allocate, reallocate, and dispose are ckalloc, ckrealloc, and ckfree with void* instead of char*.

21. Memory allocation declarations ::

#define allocate—Allocate a block on the heap and return its address.

Memory. Heap allocated, free with dispose().

input n—Number of bytes.

#define allocate(n) ((ptr)(ckalloc(n)))

22. Memory allocation declarations ::

#define dispose—Dispose a block on the heap.

Memory. Previously allocated memory is available for reuse.

input p—The address of the allocated block, variable, or array. This may be NULL.

#define dispose(p) (ckfree((chars)p))

23. Memory allocation declarations ::

#define heap—Allocate a scalar variable of type T on the heap and return its address.

Memory. Heap allocated, free with dispose().

input T—Type of the variable.

#define	heap(T) ((T*)(ckalloc(sizeof(T))))

24. Memory allocation declarations ::

#define nheap—Allocate an array of type T on the heap and return its address.

Memory. Heap allocated, free with dispose().

input T—Type of the variable.

input n—Size of the array.

#define	nheap(n,T) ((T*)(ckalloc((n)*sizeof(T))))

25. Memory allocation declarations ::

#define reallocate—Reallocate a block on the heap and return its address.

Memory. Heap allocated, free with dispose().

input n—Size of the block.

input p—Old address of the block. This may be NULL.

#define reallocate(n,p) ((ptr)(ckrealloc((chars)(p),n)))

26. Memory allocation declarations ::

#define reheap—Reallocate an array of type T on the heap and return its address.

Memory. Heap allocated, free with dispose().

input T—Type of the variable.

input n—Size of the array.

input p—Old address of the array. This may be NULL.

#define	reheap(n,T,p) ((T*)(ckrealloc((chars)(p),(n)*sizeof(T))))

27. Memory allocation declarations ::

#define zero—Zero an array of type T and return its address.

input T—Type of the variable.

input n—Size of the array.

io p—Address of the array; the contents are zero on output.

#define zero(n,T,p) (memset(p,0,(n)*sizeof(T)))

28. Memory allocation declarations ::

#define memcopy—Copy an array of type T and return its address.

input T—Type of the variable.

input n—Size of the array.

output dd—Address of the destination array; the contents are replaced.

input ss—Address of the source array; the contents are copied.

#define memcopy(n,T,dd,ss) (memcpy(dd,ss,(n)*sizeof(T)))

29. wyrmwif (4WY) Description :: incr increments the reference count if p is not NULL. decr decrements a non-null p. incr returns the object.

30. Memory allocation declarations ::

#define incr—Return p with its reference count incremented.

Memory. Reference count is incremented.

io p—An object pointer or NULL.

#ifdef DEBUG
	#define	incr(p) (wyrm_incr(p))
#else
	#define	incr(p) (wyrm_incrd(p,__FILE__,__LINE__))
#endif

31. Memory allocation declarations ::

#define decr—Decrement Tcl object reference count.

Memory. Reference count is decremented; the object may be freed.

io p—An object pointer or NULL; the object address may become undefined.

#ifdef DEBUG
	#define	decr(p) (wyrm_decr(p))
#else
	#define	decr(p) (wyrm_decrd(p,__FILE__,__LINE__))
#endif

32. Memory allocation declarations ::

proc wyrm_incr—Return p with its reference count incremented.

Memory. Reference count is incremented.

io p—An object pointer or NULL.

Obj wyrm_incr(Obj p);

33. Memory allocation declarations ::

proc wyrm_incrd—Return p with its reference count incremented.

Memory. Reference count is incremented.

input FILE—The source file where the call occurs.

input LINE—The source line number where the call occurs.

io p—An object pointer or NULL.

Obj wyrm_incrd(Obj p,chars file,int line);

34. Memory allocation declarations ::

proc wyrm_decr,—Decrement Tcl object reference count.

Memory. Reference count is decremented; the object may be freed.

io p—An object pointer or NULL; the object address may become undefined.

bool wyrm_decr(Obj p);

35. Memory allocation declarations ::

proc wyrm_decrd—Decrement Tcl object reference count.

Memory. Reference count is decremented; the object may be freed.

input FILE—The source file where the call occurs.

input LINE—The source line number where the call occurs.

io p—An object pointer or NULL; the object address may become undefined.

bool wyrm_decrd(Obj p,chars file,int line);

36. Memory allocation routines ::


Obj wyrm_incr(Obj p) {
	if (p) Tcl_IncrRefCount(p);
	return p;
}
Obj wyrm_incrd(Obj p,chars file,int line) {
	if (p) Tcl_DbIncrRefCount(p,file,line);
	return p;
}

bool wyrm_decr(Obj p) {
	bool r = p!=0;
	if (p) Tcl_DecrRefCount(p);
	return r;
}
bool wyrm_decrd(Obj p,chars file,int line) {
	bool r = p!=0;
	if (p) Tcl_DbDecrRefCount(p,file,line);
	return r;
}

37 wyrmwif (4WY) Synopsis

38 wyrmwif (4WY) Private Synopsis

39 wyrmwif (4WY) Description

40 String operator declarations

48 String operators

String operators

37. wyrmwif (4WY) Synopsis ::

bool streq(chars x,chars y);
bool strieq(chars x,chars y);
bool strbegins(chars x,chars y);
bool stribegins(chars x,chars y);
chars wyrm_cToString(long c);
long wyrm_stringToC(chars s);

38. wyrmwif (4WY) Private Synopsis ::

bool wyrm_streq(chars x,chars y);
bool wyrm_strieq(chars x,chars y);
bool wyrm_strbegins(chars x,chars y);
bool wyrm_stribegins(chars x,chars y);

39. wyrmwif (4WY) Description :: streq is true if x and y are both NULLor they are lexically equal strings.

strieq is streq, but case insensitive.

strbegins is true if x is NULL or x is a prefix of y.

stribegins is strbegins, but case insensitive.

40. String operator declarations ::

#define streq—True if strings are both NULL or equal.


#include <string.h>

#define streq(x,y) (wyrm_streq(x,y))

41. String operator declarations ::

#define strieq—True if strings are both NULL or equal, case insensitive.

#define strieq(x,y) (wyrm_strieq(x,y))

42. String operator declarations ::

#define strbegins—True if the first is NULL or begins the second.

#define strbegins(x,y) (wyrm_strbegins(x,y))

43. String operator declarations ::

#define stribegins—True if the first is NULL or begins the second, case insensitive.

#define stribegins(x,y) (wyrm_stribegins(x,y))

44. String operator declarations ::

proc wyrm_streq—True if strings are both NULL or equal.

bool wyrm_streq(chars x,chars y);

45. String operator declarations ::

proc wyrm_strieq—True if strings are both NULL or equal, insensitive.

bool wyrm_strieq(chars x,chars y);

46. String operator declarations ::

proc wyrm_strbegins—True if the first is NULL or begins the second.

bool wyrm_strbegins(chars x,chars y);

47. String operator declarations ::

proc wyrm_stribegins—True if the first is NULL or begins the second, case insensitive.

bool wyrm_stribegins(chars x,chars y);

48. String operators ::


#include <ctype.h>

bool wyrm_streq(chars x,chars y) {
	if (x==0) return y==0;
	else if (y==0) return false;
	else return strcmp(x,y)==0;
}

bool wyrm_strieq(chars x,chars y) {
	if (x==0) return y==0;
	else if (y==0) return false;
	else
		for (; tolower(*x)==tolower(*y); x++,y++)
			if (*x==0) return true;
	return false;
}

bool wyrm_strbegins(chars x,chars y) {
	if (x==0) return true;
	else if (y==0) return false;
	else return strncmp(x,y,strlen(x))==0;
}

bool wyrm_stribegins(chars x,chars y) {
	if (x==0) return true;
	else if (y==0) return false;
	else
		for (; *x; x++,y++)
			if (tolower(*x)!=tolower(*y)) return false;
	return true;
}

49. wyrmwif (4WY) Description :: wyrm_cToString and wyrm_stringToC convert between a small string packed into an integer and a normal character array, in a manner consistent with the usual implementation of multicharacter literals 'xyz'.

50. String operator declarations ::

proc wyrm_cToString—Convert packed string to a C string and return the string address.

Memory. Static allocation, overwritten by the next call.

input c—The integer with packed characters.

chars wyrm_cToString(long c);

51. String operator declarations ::

proc wyrm_stringToC—Convert a C string to packed string and return the integer value.

input c—The unpacked string.

long wyrm_stringToC(chars s);

52. String operators ::


#include <limits.h>

chars wyrm_cToString(long v) {
	static Tcl_ThreadDataKey stringKey;
	char *s = Tcl_GetThreadData(&stringKey,sizeof(long)+1);
	chars p = s+sizeof(long); unsigned long V = v;
	*p = 0; while (p>s && V>0) {*--p = V; V >>= CHAR_BIT;}
	return p;
}

long wyrm_stringToC(chars s) {
	unsigned long v=0; int n=0; bytes S = (bytes)s;
	if (S) while (*S && n++<(int)(sizeof(long))) v = (v<<CHAR_BIT) | *S++;
	return (long)v;
}

53 setp (1WY)

54 lambda (1WY)

55 Lambda command

56 Create a lambda expression token

57 Compile lambda object

58 Lambda testing

59 try (1WY)

60 extern declarations

61 wyrmwif.c

62 qutil (1WY)

Utility commands

53. setp (1WY) ::

NAME

setp — Set variables in parallel.

synopsis

::wyrm::setp {variable-name...} list-value

description

Assign the n variables to the first n elements of the list value. If The list has fewer elements, the remaining variables are assigned empty strings. If the list has more elements than variables the sublist of the remaining elements is returned; otherwise an empty list is returned.


static int setp(ClientData clientData,Intr intr,int N,Tcl_Obj *const P[]) {
	int i,q,r; Obj *Q,*R;
	if (N!=3) {
		rprintf(intr,"usage: setp {var...} list-value");
		return TCL_ERROR;
	}
	if (Tcl_ListObjGetElements(intr,P[1],&q,&Q)!=TCL_OK) return TCL_ERROR;
	if (Tcl_ListObjGetElements(intr,P[2],&r,&R)!=TCL_OK) return TCL_ERROR;
	for (i=0; i<q; i++) {
		Obj v = i>=r ? Tcl_NewObj() : R[i];
		if (!Tcl_ObjSetVar2(intr,Q[i],0,v,TCL_LEAVE_ERR_MSG)) {
			if (i>=r) decr(incr(v)); return TCL_ERROR;
		}
	}
	if (r>q) {
		Tcl_SetObjResult(intr,Tcl_NewListObj(r-q,R+q));
	} else {
		Tcl_ResetResult(intr);
	}
	return TCL_OK;
}

NAME

lambda — Anonymous procedure.

synopsis

::wyrm::lambda|::wyrm::block {parameter...} proc-body [ argument... ]

description

The lambda command creates a proc name from the current namespace, argument list, and proc body, and then compiles this as a Tcl proc, if it is not already defined as a command. The returned value is then a list of the command name and any additional parameters.

For example,

set add2 [lambda {n} {expr {$n+2}}]

then [eval $add2 3] yields 5, [eval $add2 40]>; yields 42.

The block command creates a proc in the same manner as lambda, and then immediately evaluates it.

CAVEATS

In whatever namespace lambda or block are called in (including the global space), they will create a command whose name begins with "(wyrm-lambda-body)" in that namespace. Any previously existing command with that name will be lost.


<Lambda command>

55. Lambda command :: Create a command which will evaluate the procedure body with the arguments assigned to the parameters. Originally this was encoded as a clever way of doing on the fly compiling and then releasing the proc once it was no longer need: that latter detected by when the internal representation was freed. However this, combined with monkey business in Tcl_EvalObj leads to excessive type shimmerring and excessive recompiles of the same proc.

If the lambda expression looks like an evaluable Tcl command, it is because it is. Lambda expression arguments are lappended to the expression or appended during the eval; the eval command suffices to actually trigger the evaluation with all of its arguments.


static int lambda(ClientData clientData,Intr intr,int N,Tcl_Obj *const P[]) {
	char namespaceCurrent[] = "namespace current";
	int i,rc = TCL_ERROR;
	Obj namespace = 0,token = 0;
	Obj *E,e = 0;
	if (N<3) {
		rprintf(intr,"usage: %{y}s {parameter...} {body} [arguments...]",*P);
		goto quit;
		return TCL_ERROR;
	}
	namespace = Tcl_Eval(intr,namespaceCurrent)==TCL_OK ? Tcl_GetObjResult(intr) : Tcl_NewStringObj("::",-1);
	incr(namespace);
	<Create a lambda expression token>
	E = nheap(N-2,Obj);
	E[0] = token;
	for (i=3; i<N; i++) E[i-2] = P[i];
	e = incr(Tcl_NewListObj(N-2,E));
	dispose(E);
	<Compile lambda object>
	if (clientData) {
		rc = Tcl_EvalObjEx(intr,e,TCL_EVAL_DIRECT);
	} else {
		Tcl_SetObjResult(intr,e);
		rc = TCL_OK;
	}
quit:
	decr(namespace);
	decr(token);
	decr(e);
	return rc;
}

56. Create a lambda expression token :: Each lambda expression is given a token which uniquely identifies its combination of namespace, formals, and body. All lambda expression where these are the same will have the same token.


{
	int i,n; chars s = Tcl_GetStringFromObj(namespace,&n);
	token = incr(Tcl_DuplicateObj(namespace));
	if (n<2 || s[n-2]!=':' || s[n-1]!=':') Tcl_AppendToObj(token,"::",-1);
	Tcl_AppendToObj(token,"(wyrm-lambda-body)",-1);
	for (i=1; i<3; i++) {
		Tcl_AppendToObj(token,"@@",-1);
		for (s=Tcl_GetStringFromObj(P[i],&n); n>0; n--,s++)
			if (*s<=' ' || *s>=127) {
				char B[4]; sprintf(B,"@%02X",0xFF&*s); Tcl_AppendToObj(token,B,-1);
			}else switch (*s) {
				case '@': Tcl_AppendToObj(token,"@G",-1); break;
				case '{': Tcl_AppendToObj(token,"@H",-1); break;
				case '}': Tcl_AppendToObj(token,"@I",-1); break;
				case '[': Tcl_AppendToObj(token,"@J",-1); break;
				case ']': Tcl_AppendToObj(token,"@K",-1); break;
				case 042: Tcl_AppendToObj(token,"@L",-1); break;
				case '\\': Tcl_AppendToObj(token,"@M",-1); break;
				case '$': Tcl_AppendToObj(token,"@N",-1); break;
				case ':': Tcl_AppendToObj(token,"@O",-1); break;
				default: Tcl_AppendToObj(token,s,1); break;
			}
	}
}

57. Compile lambda object :: Create the hidden proc and change the type of the proc from a string to a wyrm.lambda. When this string is freed, the entire lambda expression has been presumably freed and so the hidden proc can be released.

The compilation is done only when called upon by the expression evaluator or relambdaing. If done too early, all this work could be lost due to type shimmering.

This routine manipulates the proc element (or second) element of a lambda expression. This is a three element sublist of the namespace, lambda arguments, and lambda body.

proc compileLambdaProc—Ensure a compiled version of the lambda exists.

output intr—Where the compiled proc lives.

io proc—The proc element of a lambda expression.


{
	Tcl_CmdInfo info;
	if (!Tcl_GetCommandInfo(intr,Tcl_GetString(token),&info)) {
		Obj PROC[4],proc;
		PROC[0] = Tcl_NewStringObj("proc",-1);
		PROC[1] = token;
		PROC[2] = P[1];
		PROC[3] = P[2];
		proc = incr(Tcl_NewListObj(4,PROC));
		rc = Tcl_EvalObjEx(intr, proc,TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
		decr(proc);
		if (rc!=TCL_OK) goto quit;
	}
}

58. Lambda testing ::

NAME

try — Try and catch script evaluation.

synopsis

::wyrm::try script recoveries

recoveries ::= recovery | recoveries recovery

recovery ::= {selectors} script

selectors ::= selector | selectors selector

selector ::= return-selector | catch

description

The first script is evaluated and its return code is saved in local variable rc, the result string as rs, the error information (if an error) in ei, and the error code (if an error) in ec. Then the recoveries are examined in order.

If any of return-selector matches the value of $rc and if the optional glob-pattern matches the $rs (* matches any value of $rc), then the script in the recovery is evaluated. If the catch was included in the selectors the result of the script is ignored; otherwise unless the script returns a TCL_OK result, that becomes the result of the try-command and subsequent recovery is stopped. (If the recovery does a return without a catch selector it will stop the try-command.)

If reset is specified and the body is selected, the overall return code is cleared to TCL_OK.

If more than recovery can match the results, each is evaluated until the try-command is stopped or the recoveries are exhausted.

If the try-command is stopped, that is its result. Otherwise the first results are the results.


static int tryBlock(ClientData clientData,Intr intr,int N,Tcl_Obj *const P[]) {
	int rc = TCL_OK; Obj rs=0,ei=0,ec=0; chars RS,EI; int n;
	if (N<2 || (N&1)==1) {
		rprintf(intr,"usage: try script [recovery-selectors recovery-script]...");
		return TCL_ERROR;
	}
	Tcl_AllowExceptions(intr);
	rc = Tcl_EvalObjEx(intr,P[1],TCL_EVAL_DIRECT);
	rs = incr(Tcl_GetObjResult(intr));
	ei = incr(Tcl_GetVar2Ex(intr,"errorInfo",0,TCL_GLOBAL_ONLY));
	ec = incr(Tcl_GetVar2Ex(intr,"errorCode",0,TCL_GLOBAL_ONLY));
	if (!Tcl_SetVar2Ex(intr,"rc",0,Tcl_NewIntObj(rc),TCL_LEAVE_ERR_MSG)) goto exit;
	if (!Tcl_SetVar2Ex(intr,"rs",0,rs,TCL_LEAVE_ERR_MSG)) {rc = TCL_ERROR; goto exit;}
	if (!ei) ei = incr(Tcl_NewObj());
	if (!Tcl_SetVar2Ex(intr,"ei",0,ei,TCL_LEAVE_ERR_MSG)) {rc = TCL_ERROR; goto exit;}
	if (!ec) ec = incr(Tcl_NewObj());
	if (!Tcl_SetVar2Ex(intr,"ec",0,ec,TCL_LEAVE_ERR_MSG)) {rc = TCL_ERROR; goto exit;}
	RS = Tcl_GetStringFromObj(rs,0);
	while (N-=2, P+=2, N>0) {
		int M; Obj *Q; bool selected=false,catching=false,resetting=false; int rc1;
		if (Tcl_ListObjGetElements(intr,P[0],&M,&Q)!=TCL_OK) {rc = TCL_ERROR; goto exit;}
		for (; M>0; --M,++Q) {
			chars s = Tcl_GetStringFromObj(*Q,0);
			if (strieq(s,"okay"))			selected = selected || rc==TCL_OK;
			else if (strieq(s,"error"))		selected = selected || rc==TCL_ERROR;
			else if (strieq(s,"return"))	selected = selected || rc==TCL_RETURN;
			else if (strieq(s,"break"))		selected = selected || rc==TCL_BREAK;
			else if (strieq(s,"continue"))	selected = selected || rc==TCL_CONTINUE;
			else if (strieq(s,"*"))			selected = true;
			else if (strieq(s,"catch"))		catching = true;
			else if (strieq(s,"reset"))	resetting = true;
			else if (stribegins("okay:",s))
				selected = selected
					|| (rc==TCL_OK && Tcl_StringMatch(RS,s+5));
			else if (stribegins("error:",s))
				selected = selected
					|| (rc==TCL_ERROR && Tcl_StringMatch(RS,s+6));
			else if (stribegins("return:",s))
				selected = selected
					|| (rc==TCL_RETURN && Tcl_StringMatch(RS,s+7));
			else {
				Tcl_ResetResult(intr);
				Tcl_AppendResult(intr,"try: unknown selector: ",s,0);
				rc = TCL_ERROR; goto exit;
			}
		}
		if (selected) {
			if (resetting) {
				if (Tcl_SetVar2Ex(intr,"rc",0,Tcl_NewIntObj(TCL_OK),TCL_LEAVE_ERR_MSG)) {
					rc = TCL_OK;
				}else {
					rc = TCL_ERROR;
					goto exit;
				}
			}
			Tcl_AllowExceptions(intr);
			rc1 = Tcl_EvalObjEx(intr,P[1],TCL_EVAL_DIRECT);
			if (!catching && rc1!=TCL_OK) {
				rc = rc1; goto exit;
			}
		}
	}
	Tcl_ResetResult(intr);
	Tcl_SetObjResult(intr,rs);
	EI = Tcl_GetStringFromObj(ei,&n);
	Tcl_AddObjErrorInfo(intr,EI,n);
	Tcl_SetObjErrorCode(intr,ec);
exit:
	decr(rs); decr(ei); decr(ec);
	return rc;
}

60. extern declarations ::

int wyrm_utilityCommandInit(Intr intr);

61. wyrmwif.c ::


static int about(ClientData clientData,Intr intr,int N,Tcl_Obj *const P[]) {
	rprintf(intr,
			"Wyrmwif Tcl extensions\n"
			"Copyright (C) 2002, 2004 SM Ryan.  All rights reserved.\n"
			"Version " VERSION "\n"
			"Build date " __DATE__
	);
	return TCL_OK;
}

int wyrm_utilityCommandInit(Intr intr) {
	char package[] =
		"namespace eval ::wyrm {\n"
		"	namespace export setp\n"
		"	namespace export lambda\n"
		"	namespace export block\n"
		"	namespace export try\n"
		"}\n";
	Tcl_CreateObjCommand(intr,"::wyrm::about",about,0,0);
	Tcl_CreateObjCommand(intr,"::wyrm::setp",setp,0,0);
	Tcl_CreateObjCommand(intr,"::wyrm::lambda",lambda,0,0);
	Tcl_CreateObjCommand(intr,"::wyrm::block",lambda,"block",0);
	Tcl_CreateObjCommand(intr,"::wyrm::try",tryBlock,0,0);
	return Tcl_Eval(intr,package);
}