--- electric-6.05.orig/examples/languages/test.scm +++ electric-6.05/examples/languages/test.scm @@ -0,0 +1,124 @@ +; In LISP, load this file with +; (load 'test.scm) +; +; Then run this predicate to build circuitry: +; (makefacet) +; +; And run this predicate to list the objects in a subarea of the current facet: +; (listobjects) + +(display "To build facets, type: (makefacet)") (newline) + +(define makefacet + (lambda () + ; create a facet called "tran-contact" in the current library + (define myfacet (newnodeproto 'tran-contact (curlib))) + + ; get pointers to the "P-Transistor" and "Metal-1-Polysilicon-1-Con" primitives + (define tran (getnodeproto 'P-Transistor)) + (define contact (getnodeproto 'Metal-1-Polysilicon-1-Con)) + + ; get default sizes of these primitives + (define tlowx (getval tran 'lowx)) + (define thighx (getval tran 'highx)) + (define tlowy (getval tran 'lowy)) + (define thighy (getval tran 'highy)) + (define clowx (getval contact 'lowx)) + (define chighx (getval contact 'highx)) + (define clowy (getval contact 'lowy)) + (define chighy (getval contact 'highy)) + + ; get pointer to Polysilicon arc and its default width + (define arctype (getarcproto 'Polysilicon-1)) + (define width (getval arctype 'nominalwidth)) + + ; create the transistor and the contact to its left + (define c1 (newnodeinst contact clowx chighx clowy chighy 0 0 myfacet)) + (define t1 (newnodeinst tran (+ tlowx 8000) (+ thighx 8000) tlowy thighy 0 0 myfacet)) + + ; get the transistor's left port coordinates + (define tport (getportproto tran 'p-trans-poly-left)) + (define tpos (portposition t1 tport)) + + ; get the contacts's only port coordinates + (define cport (getval contact 'firstportproto)) + (define cpos (portposition c1 cport)) + + ; run a wire between the primitives + (newarcinst arctype width 0 t1 tport (vector-ref tpos 0) (vector-ref tpos 1) + c1 cport (vector-ref cpos 0) (vector-ref cpos 1) myfacet) + + ; make ports from the transistor + (newportproto myfacet t1 (getportproto tran 'p-trans-diff-top) 'topdiff) + (newportproto myfacet t1 (getportproto tran 'p-trans-diff-bottom) 'botdiff) + + ; create a facet called "two-trans" + (define higherfacet (newnodeproto 'two-trans (curlib))) + + ; get pointer to the "tran-contact" facet + (define t-c (getnodeproto 'tran-contact)) + + ; get size of this facet + (define lowx (getval t-c 'lowx)) + (define highx (getval t-c 'highx)) + (define lowy (getval t-c 'lowy)) + (define highy (getval t-c 'highy)) + + ; create the two facet instances, one above the other + (define o1 (newnodeinst t-c lowx highx lowy highy 0 0 higherfacet)) + (define o2 (newnodeinst t-c lowx highx (+ lowy 10000) (+ highy 10000) + 0 0 higherfacet)) + + ; get pointer to P-Diffusion arc and its default width + (define darctype (getarcproto 'P-Active)) + (define dwidth (getval darctype 'nominalwidth)) + + ; get the bottom facet's top port + (define lowport (getportproto myfacet 'topdiff)) + (define lowpos (portposition o1 lowport)) + + ; get the top facet's bottom port + (define highport (getportproto myfacet 'botdiff)) + (define highpos (portposition o2 highport)) + + ; run a wire between the primitives + (newarcinst darctype dwidth 0 + o1 lowport (vector-ref lowpos 0) (vector-ref lowpos 1) + o2 highport (vector-ref highpos 0) (vector-ref highpos 1) higherfacet) + ) +) + +(define listobjects + (lambda () + (define myfacet (getval (curlib) 'curnodeproto)) + (define key (initsearch 2000 10000 -3000 3000 myfacet)) + (do + ( + (object (nextobject key) (nextobject key)) + ) + ((null? object)) + + (define type (getval object 'entrytype)) + (if (= type 1) + (format #t "Found ~s node~%" + (describenode (getval object 'entryaddr)) + ) + (format #t "Found ~s arc~%" + (getval + (getval (getval object 'entryaddr) 'proto) + 'protoname) + ) + ) + ) + ) +) + +(define describenode + (lambda (node) + (define proto (getval node 'proto)) + (if (= (getval proto 'index) 0) + (getval (getval proto 'cell) 'cellname) + (getval proto 'primname) + ) + ) +) --- electric-6.05.orig/examples/languages/test.tcl +++ electric-6.05/examples/languages/test.tcl @@ -0,0 +1,133 @@ +; In TCL, load this file with +; source test.tcl +; +; Then run these predicates to build circuitry: +; makefacet +; makehier +; +; And run this predicate to list the objects in a subarea of the current facet: +; listarea + +proc makefacet {} { + # create a facet called "tran-contact" in the current library + set myfacet [newnodeproto tran-contact [curlib]] + + # get "S-Transistor" and "Metal-1-Polysilicon-Con" primitives + set tran [getnodeproto S-Transistor] + set contact [getnodeproto Metal-1-Polysilicon-Con] + + # get default sizes of these primitives + set tlowx [getval $tran lowx] + set thighx [getval $tran highx] + set tlowy [getval $tran lowy] + set thighy [getval $tran highy] + set clowx [getval $contact lowx] + set chighx [getval $contact highx] + set clowy [getval $contact lowy] + set chighy [getval $contact highy] + + # get pointer to Polysilicon arc and its default width + set arctype [getarcproto Polysilicon] + set width [getval $arctype nominalwidth] + + # create the transistor and the contact to its left + set c1 [newnodeinst $contact $clowx $chighx $clowy $chighy 0 0 $myfacet] + set t1 [newnodeinst $tran [expr $tlowx+40000] [expr $thighx+40000] $tlowy $thighy 0 0 $myfacet] + + # get the transistor's left port coordinates + set tport [getportproto $tran s-trans-poly-left] + set tpos [portposition $t1 $tport] + + # get the contacts's only port coordinates + set cport [getval $contact firstportproto] + set cpos [portposition $c1 $cport] + + # run a wire between the primitives + newarcinst $arctype $width 0 $t1 $tport [lindex $tpos 0] [lindex $tpos 1] $c1 $cport [lindex $cpos 0] [lindex $cpos 1] $myfacet + + # create ports + newportproto $myfacet $t1 [getportproto $tran s-trans-diff-top] topdiff + newportproto $myfacet $t1 [getportproto $tran s-trans-diff-bottom] botdiff + + # return the facet + return $myfacet +} + +proc makehier {} { + # create a facet called "two-trans" + set higherfacet [newnodeproto two-trans [curlib]] + + # get pointer to the "tran-contact" facet + set tc [getnodeproto tran-contact] + + # get size of this facet + set lowx [getval $tc lowx] + set highx [getval $tc highx] + set lowy [getval $tc lowy] + set highy [getval $tc highy] + + # create the two facet instances, one above the other + set o1 [newnodeinst $tc $lowx $highx $lowy $highy 0 0 $higherfacet] + set o2 [newnodeinst $tc $lowx $highx [expr $lowy+70000] [expr $highy+70000] 0 0 $higherfacet] + + # get pointer to S-Active arc and its default width + set darctype [getarcproto S-Active] + set dwidth [getval $darctype nominalwidth] + + # get the bottom facet's top port + set lowport [getportproto $tc topdiff] + set lowpos [portposition $o1 $lowport] + + # get the top facet's bottom port + set highport [getportproto $tc botdiff] + set highpos [portposition $o2 $highport] + + # run a wire between the primitives + newarcinst $darctype $dwidth 0 $o1 $lowport [lindex $lowpos 0] [lindex $lowpos 1] $o2 $highport [lindex $highpos 0] [lindex $highpos 1] $higherfacet +} + +proc listnodes {} { + set myfacet [getval [curlib] curnodeproto] + for { set node [getval $myfacet firstnodeinst] } { [string c $node #nodeinst-1] != 0 } { set node [getval $node nextnodeinst] } { + puts stdout [format "Found %s node" [describenode $node]] + } +} + +proc listarcs {} { + set myfacet [getval [curlib] curnodeproto] + for { set arc [getval $myfacet firstarcinst] } { [string c $arc #arcinst-1] != 0 } { set arc [getval $arc nextarcinst] } { + puts stdout [format "Found %s arc" [getval [getval $arc proto] protoname]] + } +} + +proc listarea {} { + set myfacet [getval [curlib] curnodeproto] + set key [initsearch -10000 50000 -15000 15000 $myfacet] + for { set object [nextobject $key] } { [string c $object #geom-1] != 0 } { set object [nextobject $key] } { + set type [getval $object entrytype] + if { $type == 1 } { + puts stdout [format "Found %s node" [describenode [getval $object entryaddr]]] + } else { + puts stdout [format "Found %s arc" [getval [getval [getval $object entryaddr] proto] protoname]] + } + } +} + +proc describenode node { + set proto [getval $node proto] + if { [getval $proto index] == 0} { + return [getval [getval $proto cell] cellname] + } + return [getval $proto primname] +} + +proc nmostransistorsize {} { + set path [gettraversalpath] + set len [llength $path] + if { $len <= 0 } { + return "nmos2/2" + } + set last [lindex $path [expr $len-1]] + set size [getval $last transistorsize] + return [concat nmos$size] +} --- electric-6.05.orig/examples/languages/test.java +++ electric-6.05/examples/languages/test.java @@ -0,0 +1,189 @@ +// To compile this code: +// Move it to the current directory +// Run "Command prompt" +// cd to the current directory +// type "javac -classpath lib\java test.java" +// +// then, inside of Electric's Java interpreter, type: +// test.ex1 +// test.ex2 +// test.ex3 +// test.ex4 +// test.doVoid/Boolean/Byte/Char/Short/Int/Long/Float/Double/String + +import COM.staticfreesoft.*; + +class test +{ + public static Object ex1() + { + /* create a facet called "tran-contact" in the current library */ + electric.nodeproto myfacet = electric.newNodeProto("tran-contact", electric.curLib()); + + /* get pointers to primitives */ + electric.nodeproto tran = electric.getNodeProto("P-Transistor"); + electric.nodeproto contact = electric.getNodeProto("Metal-1-Polysilicon-1-Con"); + + /* get default sizes of these primitives */ + int tlowx = ((Integer)electric.getVal(tran, "lowx")).intValue(); + int thighx = ((Integer)electric.getVal(tran, "highx")).intValue(); + int tlowy = ((Integer)electric.getVal(tran, "lowy")).intValue(); + int thighy = ((Integer)electric.getVal(tran, "highy")).intValue(); + int clowx = ((Integer)electric.getVal(contact, "lowx")).intValue(); + int chighx = ((Integer)electric.getVal(contact, "highx")).intValue(); + int clowy = ((Integer)electric.getVal(contact, "lowy")).intValue(); + int chighy = ((Integer)electric.getVal(contact, "highy")).intValue(); + + /* get pointer to Polysilicon arc and its default width */ + electric.arcproto arctype = electric.getArcProto("Polysilicon-1"); + int width = ((Integer)electric.getVal(arctype, "nominalwidth")).intValue(); + + /* create the transistor and the contact to its left */ + electric.nodeinst c1 = electric.newNodeInst(contact, clowx, chighx, clowy, chighy, + 0, 0, myfacet); + electric.nodeinst t1 = electric.newNodeInst(tran, tlowx+8000, thighx+8000, + tlowy, thighy, 0, 0, myfacet); + + /* get the transistor's left port coordinates */ + electric.portproto tport = electric.getPortProto(tran, "p-trans-poly-left"); + Integer[] tpos = electric.portPosition(t1, tport); + + /* get the contacts's only port coordinates */ + electric.portproto cport = (electric.portproto)electric.getVal(contact, "firstportproto"); + Integer[] cpos = electric.portPosition(c1, cport); + + /* run a wire between the primitives */ + electric.arcinst ai = electric.newArcInst(arctype, width, 0, + t1, tport, tpos[0].intValue(), tpos[1].intValue(), + c1, cport, cpos[0].intValue(), cpos[1].intValue(), myfacet); + + /* make ports on the transistor */ + electric.portproto topport = electric.getPortProto(tran, "p-trans-diff-top"); + electric.portproto botport = electric.getPortProto(tran, "p-trans-diff-bottom"); + electric.portproto p1 = electric.newPortProto(myfacet, t1, topport, "topdiff"); + electric.portproto p2 = electric.newPortProto(myfacet, t1, botport, "botdiff"); + + /* name the arc */ + electric.setVal(ai, "ARC_name", "Connection", electric.vdisplay); + + /* create a pure-layer node with outline information */ + electric.nodeproto m1node = electric.getNodeProto("Metal-1-Node"); + electric.nodeinst mn = electric.newNodeInst(m1node, 3000, 5000, 2000, 4000, + 0, 0, myfacet); + int[] outline = new int[8]; + outline[0] = -1000; outline[1] = 0; + outline[2] = 0; outline[3] = 1000; + outline[4] = 1000; outline[5] = 0; + outline[6] = 0; outline[7] = -1000; + electric.setVal(mn, "trace", outline, 0); + + System.out.println("Created the facet 'tran-contact'"); + return(myfacet); + } + + public static Object ex2() + { + /* create a facet called "two-trans" */ + electric.nodeproto higherfacet = electric.newNodeProto("two-trans", electric.curLib()); + + /* get pointer to the "tran-contact" facet */ + electric.nodeproto tc = electric.getNodeProto("tran-contact"); + + /* get size of this facet */ + int lowx = ((Integer)electric.getVal(tc, "lowx")).intValue(); + int highx = ((Integer)electric.getVal(tc, "highx")).intValue(); + int lowy = ((Integer)electric.getVal(tc, "lowy")).intValue(); + int highy = ((Integer)electric.getVal(tc, "highy")).intValue(); + + /* create the two facet instances, one above the other */ + electric.nodeinst o1 = electric.newNodeInst(tc, lowx, highx, lowy, highy, + 0, 0, higherfacet); + electric.nodeinst o2 = electric.newNodeInst(tc, lowx, highx, lowy+10000, highy+10000, + 0, 0, higherfacet); + + /* get pointer to P-Active arc and its default width */ + electric.arcproto darctype = electric.getArcProto("P-Active"); + int dwidth = ((Integer)electric.getVal(darctype, "nominalwidth")).intValue(); + + /* get the bottom facet's top port */ + electric.portproto lowport = electric.getPortProto(tc, "topdiff"); + Integer[] lowpos = electric.portPosition(o1, lowport); + + /* get the top facet's bottom port */ + electric.portproto highport = electric.getPortProto(tc, "botdiff"); + Integer[] highpos = electric.portPosition(o2, highport); + + /* run a wire between the primitives */ + electric.arcinst ai = electric.newArcInst(darctype, dwidth, 0, + o1, lowport, lowpos[0].intValue(), lowpos[1].intValue(), + o2, highport, highpos[0].intValue(), highpos[1].intValue(), higherfacet); + + System.out.println("Created the facet 'two-trans'"); + + /* invoke the "help" command */ + electric.aid user = electric.getAid("user"); + String[] message = new String[2]; + message[0] = "show"; + message[1] = "technologies"; + electric.tellAid(user, 2, message); + return(higherfacet); + } + + public static String describenode(electric.nodeinst node) + { + electric.nodeproto proto = (electric.nodeproto)electric.getVal(node, "proto"); + int primindex = ((Integer)electric.getVal(proto, "primindex")).intValue(); + if (primindex == 0) + { + return( (String) electric.getVal( (electric.cell)electric.getVal(proto, "cell"), "cellname")); + } + return((String)electric.getVal(proto, "primname")); + } + + public static void ex3() + { + electric.nodeinst ni; + electric.nodeproto myfacet = electric.getNodeProto("tran-contact"); + + for(ni = (electric.nodeinst)electric.getVal(myfacet, "firstnodeinst"); + !ni.isNull(); + ni = (electric.nodeinst)electric.getVal(ni, "nextnodeinst")) + { + System.out.println("Found node " + describenode(ni)); + } + } + + public static void ex4() + { + electric.nodeproto myfacet = electric.getNodeProto("tran-contact"); + int key = electric.initSearch(2000, 10000, -3000, 3000, myfacet); + for(;;) + { + electric.geom object = (electric.geom)electric.nextObject(key); + if (object.isNull()) break; + int type = ((Integer)electric.getVal(object, "entrytype")).intValue(); + if (type == 1) + { + electric.nodeinst ni = (electric.nodeinst)electric.getVal(object, "entryaddr"); + System.out.println("Found node " + describenode(ni)); + } else + { + electric.arcinst ai = (electric.arcinst)electric.getVal(object, "entryaddr"); + String arcname = (String)electric.getVal((electric.arcproto)electric.getVal(ai, "proto"), "protoname"); + System.out.println("Found arc " + arcname); + } + } + } + + public static void doVoid() {} + public static boolean doBoolean() { return(true); } + public static byte doByte() { return(24); } + public static char doChar() { return('A'); } + public static short doShort() { return(5000); } + public static int doInt() { return(2000000); } + public static long doLong() { return(123456789); } + public static float doFloat() { return(3.14159f); } + public static double doDouble() { return(3.1415926535); } + public static String doString() { return("Howdy"); } + public static void doExit() { System.exit(12); } +} --- electric-6.05.orig/examples/tool-SimulateSPICE.spi +++ electric-6.05/examples/tool-SimulateSPICE.spi @@ -0,0 +1,34 @@ +*** FACET tool-SimulateSPICE FROM LIBRARY samples *** +*** VERSION 1 LAST REVISED Thu Nov 4 09:46:36 1999 +*** EXTRACTED BY ELECTRIC DESIGN SYSTEM, VERSION 6.02 +*** UC SPICE *** , MIN_RESIST 50.000000, MIN_CAPAC 0.040000FF +.OPTIONS NOMOD NOPAGE +*CMOS/BULK-NWELL (PRELIMINARY PARAMETERS) +.OPTIONS NOMOD DEFL=3UM DEFW=3UM DEFAD=70P DEFAS=70P LIMPTS=1000 ++ITL4=1000 ITL5=0 RELTOL=0.01 ABSTOL=500PA VNTOL=500UV LVLTIM=2 ++LVLCOD=1 +.MODEL N NMOS LEVEL=1 ++KP=60E-6 VTO=0.7 GAMMA=0.3 LAMBDA=0.05 PHI=0.6 ++LD=0.4E-6 TOX=40E-9 CGSO=2.0E-10 CGDO=2.0E-10 CJ=.2MF/M^2 +.MODEL P PMOS LEVEL=1 ++KP=20E-6 VTO=0.7 GAMMA=0.4 LAMBDA=0.05 PHI=0.6 ++LD=0.6E-6 TOX=40E-9 CGSO=3.0E-10 CGDO=3.0E-10 CJ=.2MF/M^2 +.MODEL DIFFCAP D CJO=.2MF/M^2 + +*** TOP LEVEL FACET: tool-SimulateSPICE{lay} +** POWER NET: power +** GROUND NET: 0 (ground) +** PIN 5: power (network: power) +** PIN 3: in (network: in) +** PIN 2: out (network: out) +Mnode12 0 3 2 0 N L=0.40U W=0.60U AS= 1.12P AD= 0.36P PS= 4.40U PD= 2.40U +Mnode11 2 3 5 5 P L=0.40U W=0.60U AS= 0.36P AD= 1.12P PS= 2.40U PD= 4.40U +** Extracted Parasitic Elements: +C1 3 0 0.28F +C2 2 0 0.22F +** Sources and special nodes: +Vnode5 3 0 PWL(0NS 0 3NS 0 4NS 5) +Vnode4 5 0 DC 5 +.PRINT TRAN V(0) V(2) +.TRAN .2NS 7NS 0NS .2NS +.END --- electric-6.05.orig/examples/tool-SimulateVERILOG.v +++ electric-6.05/examples/tool-SimulateVERILOG.v @@ -0,0 +1,32 @@ +/* Verilog for facet tool-SimulateVERILOG{sch} from Library samples */ +/* Created on Fri Apr 2 09:59:22 1999 */ +/* Last revised on Thu Sep 21 10:35:14 2000 */ +/* Written on Fri Dec 1 08:57:53 2000 by Electric VLSI Design System, version 6.02 */ + +module tool_SimulateVERILOG(a, m, z); + input a; + input [0:3] m; + input [0:3] z; + + wire ImpInv1; + wire [0:3] d; + wire net1; + + /* user-specified Verilog declarations */ + wire b, c; + wire e, f; + + /* user-specified Verilog code */ + a = b + c; + b = e - f; + + /* automatically generated Verilog */ + xor node5(z[0], z[3], a); + inv Imp1 (ImpInv1, z[2]); + or node3(net1, z[3], a, ImpInv1); + not node4(z[1], net1); + and node7_0(d[0], z[0], m[0]); + and node7_1(d[1], z[1], m[1]); + and node7_2(d[2], z[2], m[2]); + and node7_3(d[3], z[3], m[3]); +endmodule /* tool_SimulateVERILOG */ --- electric-6.05.orig/lib/tcl/history.tcl +++ electric-6.05/lib/tcl/history.tcl @@ -0,0 +1,369 @@ +# history.tcl -- +# +# Implementation of the history command. +# +# SCCS: @(#) history.tcl 1.7 97/08/07 16:45:50 +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# The tcl::history array holds the history list and +# some additional bookkeeping variables. +# +# nextid the index used for the next history list item. +# keep the max size of the history list +# oldest the index of the oldest item in the history. + +namespace eval tcl { + variable history + if ![info exists history] { + array set history { + nextid 0 + keep 20 + oldest -20 + } + } +} + +# history -- +# +# This is the main history command. See the man page for its interface. +# This does argument checking and calls helper procedures in the +# history namespace. + +proc history {args} { + set len [llength $args] + if {$len == 0} { + return [tcl::HistInfo] + } + set key [lindex $args 0] + set options "add, change, clear, event, info, keep, nextid, or redo" + switch -glob -- $key { + a* { # history add + + if {$len > 3} { + return -code error "wrong # args: should be \"history add event ?exec?\"" + } + if {![string match $key* add]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 3} { + set arg [lindex $args 2] + if {! ([string match e* $arg] && [string match $arg* exec])} { + return -code error "bad argument \"$arg\": should be \"exec\"" + } + } + return [tcl::HistAdd [lindex $args 1] [lindex $args 2]] + } + ch* { # history change + + if {($len > 3) || ($len < 2)} { + return -code error "wrong # args: should be \"history change newValue ?event?\"" + } + if {![string match $key* change]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 2} { + set event 0 + } else { + set event [lindex $args 2] + } + + return [tcl::HistChange [lindex $args 1] $event] + } + cl* { # history clear + + if {($len > 1)} { + return -code error "wrong # args: should be \"history clear\"" + } + if {![string match $key* clear]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistClear] + } + e* { # history event + + if {$len > 2} { + return -code error "wrong # args: should be \"history event ?event?\"" + } + if {![string match $key* event]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 1} { + set event -1 + } else { + set event [lindex $args 1] + } + return [tcl::HistEvent $event] + } + i* { # history info + + if {$len > 2} { + return -code error "wrong # args: should be \"history info ?count?\"" + } + if {![string match $key* info]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistInfo [lindex $args 1]] + } + k* { # history keep + + if {$len > 2} { + return -code error "wrong # args: should be \"history keep ?count?\"" + } + if {$len == 1} { + return [tcl::HistKeep] + } else { + set limit [lindex $args 1] + if {[catch {expr $limit}] || ($limit < 0)} { + return -code error "illegal keep count \"$limit\"" + } + return [tcl::HistKeep $limit] + } + } + n* { # history nextid + + if {$len > 1} { + return -code error "wrong # args: should be \"history nextid\"" + } + if {![string match $key* nextid]} { + return -code error "bad option \"$key\": must be $options" + } + return [expr $tcl::history(nextid) + 1] + } + r* { # history redo + + if {$len > 2} { + return -code error "wrong # args: should be \"history redo ?event?\"" + } + if {![string match $key* redo]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistRedo [lindex $args 1]] + } + default { + return -code error "bad option \"$key\": must be $options" + } + } +} + +# tcl::HistAdd -- +# +# Add an item to the history, and optionally eval it at the global scope +# +# Parameters: +# command the command to add +# exec (optional) a substring of "exec" causes the +# command to be evaled. +# Results: +# If executing, then the results of the command are returned +# +# Side Effects: +# Adds to the history list + + proc tcl::HistAdd {command {exec {}}} { + variable history + set i [incr history(nextid)] + set history($i) $command + set j [incr history(oldest)] + if {[info exists history($j)]} {unset history($j)} + if {[string match e* $exec]} { + return [uplevel #0 $command] + } else { + return {} + } +} + +# tcl::HistKeep -- +# +# Set or query the limit on the length of the history list +# +# Parameters: +# limit (optional) the length of the history list +# +# Results: +# If no limit is specified, the current limit is returned +# +# Side Effects: +# Updates history(keep) if a limit is specified + + proc tcl::HistKeep {{limit {}}} { + variable history + if {[string length $limit] == 0} { + return $history(keep) + } else { + set oldold $history(oldest) + set history(oldest) [expr $history(nextid) - $limit] + for {} {$oldold <= $history(oldest)} {incr oldold} { + if {[info exists history($oldold)]} {unset history($oldold)} + } + set history(keep) $limit + } +} + +# tcl::HistClear -- +# +# Erase the history list +# +# Parameters: +# none +# +# Results: +# none +# +# Side Effects: +# Resets the history array, except for the keep limit + + proc tcl::HistClear {} { + variable history + set keep $history(keep) + unset history + array set history [list \ + nextid 0 \ + keep $keep \ + oldest -$keep \ + ] +} + +# tcl::HistInfo -- +# +# Return a pretty-printed version of the history list +# +# Parameters: +# num (optional) the length of the history list to return +# +# Results: +# A formatted history list + + proc tcl::HistInfo {{num {}}} { + variable history + if {$num == {}} { + set num [expr $history(keep) + 1] + } + set result {} + set newline "" + for {set i [expr $history(nextid) - $num + 1]} \ + {$i <= $history(nextid)} {incr i} { + if ![info exists history($i)] { + continue + } + set cmd [string trimright $history($i) \ \n] + regsub -all \n $cmd "\n\t" cmd + append result $newline[format "%6d %s" $i $cmd] + set newline \n + } + return $result +} + +# tcl::HistRedo -- +# +# Fetch the previous or specified event, execute it, and then +# replace the current history item with that event. +# +# Parameters: +# event (optional) index of history item to redo. Defaults to -1, +# which means the previous event. +# +# Results: +# Those of the command being redone. +# +# Side Effects: +# Replaces the current history list item with the one being redone. + + proc tcl::HistRedo {{event -1}} { + variable history + if {[string length $event] == 0} { + set event -1 + } + set i [HistIndex $event] + if {$i == $history(nextid)} { + return -code error "cannot redo the current event" + } + set cmd $history($i) + HistChange $cmd 0 + uplevel #0 $cmd +} + +# tcl::HistIndex -- +# +# Map from an event specifier to an index in the history list. +# +# Parameters: +# event index of history item to redo. +# If this is a positive number, it is used directly. +# If it is a negative number, then it counts back to a previous +# event, where -1 is the most recent event. +# A string can be matched, either by being the prefix of +# a command or by matching a command with string match. +# +# Results: +# The index into history, or an error if the index didn't match. + + proc tcl::HistIndex {event} { + variable history + if {[catch {expr $event}]} { + for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} { + if {[string match $event* $history($i)]} { + return $i; + } + if {[string match $event $history($i)]} { + return $i; + } + } + return -code error "no event matches \"$event\"" + } elseif {$event <= 0} { + set i [expr $history(nextid) + $event] + } else { + set i $event + } + if {$i <= $history(oldest)} { + return -code error "event \"$event\" is too far in the past" + } + if {$i > $history(nextid)} { + return -code error "event \"$event\" hasn't occured yet" + } + return $i +} + +# tcl::HistEvent -- +# +# Map from an event specifier to the value in the history list. +# +# Parameters: +# event index of history item to redo. See index for a +# description of possible event patterns. +# +# Results: +# The value from the history list. + + proc tcl::HistEvent {event} { + variable history + set i [HistIndex $event] + if {[info exists history($i)]} { + return [string trimright $history($i) \ \n] + } else { + return ""; + } +} + +# tcl::HistChange -- +# +# Replace a value in the history list. +# +# Parameters: +# cmd The new value to put into the history list. +# event (optional) index of history item to redo. See index for a +# description of possible event patterns. This defaults +# to 0, which specifies the current event. +# +# Side Effects: +# Changes the history list. + + proc tcl::HistChange {cmd {event 0}} { + variable history + set i [HistIndex $event] + set history($i) $cmd +} --- electric-6.05.orig/lib/tcl/http.tcl +++ electric-6.05/lib/tcl/http.tcl @@ -0,0 +1,292 @@ +# http.tcl +# Client-side HTTP for GET, POST, and HEAD commands. +# These routines can be used in untrusted code that uses the Safesock +# security policy. +# These procedures use a callback interface to avoid using vwait, +# which is not defined in the safe base. +# +# SCCS: @(#) http.tcl 1.2 97/01/22 13:12:02 +# +# See the http.n man page for documentation + +package provide http 1.0 + +if {[info commands "unsupported0"] == "unsupported0"} { + rename unsupported0 copychannel +} +array set http { + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 1.0} + -proxyfilter httpProxyRequired +} +proc http_config {args} { + global http + if {[llength $args] == 0} { + set result {} + foreach name [lsort [array names http -*]] { + lappend result $name $http($name) + } + return $result + } elseif {[llength $args] == 1} { + set flag [lindex $args 0] + if {[regexp -- {^-(proxyhost|proxyport|proxyfilter|agent)$} $flag]} { + return $http($flag) + } else { + return -code error "Unknown option $flag, must be -proxyfilter, -proxyhost, -proxyport, or -useragent" + } + } else { + foreach {flag value} $args { + switch -- $flag { + -proxyhost - + -proxyport - + -proxyfilter - + -useragent { + set http($flag) $value + } + default { + return -code error "Unknown option $flag, must be -proxyfilter, -proxyhost, -proxyport, or -useragent" + } + } + } + } +} + +proc http_reset { token } { + upvar #0 $token state + set state(status) reset + catch {fileevent $state(sock) readable {}} + catch {eval $state(-command) {$token}} + catch {close $state(sock)} + catch {unset state} +} +proc http_get { url args } { + global http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token http#[incr http(uid)] + upvar #0 $token state + http_reset $token + array set state { + -command {# } + -blocksize 8192 + -validate 0 + -headers {} + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + foreach {flag value} $args { + switch -- $flag { + -blocksize - + -channel - + -command - + -headers - + -progress - + -query - + -validate { + set state($flag) $value + } + default { + return -code error "Unknown option $flag: can be -blocksize, -channel, -command, -headers, -progress, -query, or -validate" + } + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + if {[string length $proto] == 0} { + set url http://$url + } + set state(url) $url + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + # Send data in cr-lf format, but accept any line terminators + fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) + # this is disallowed in safe interpreters, but the socket + # is already in non-blocking mode in that case. + catch {fconfigure $s -blocking off} + set len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + puts $s "$how $srvurl HTTP/1.0" + puts $s "Accept: */*" + puts $s "Host: $host" + puts $s "User-Agent: $http(-useragent)" + foreach {key value} $state(-headers) { + regsub -all \[\n\r\] $value {} value + set key [string trim $key] + if {[string length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Transfer-Encoding: x-url-encoding" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list httpEvent $token] + return $token +} + + proc httpEvent {token} { + upvar #0 $token state + set s $state(sock) + + if [eof $s] then { + close $s + if {$state(state) == "header"} { + # Premature eof + set state(status) eof + } else { + set state(status) ok + } + set state(state) eof + eval $state(-command) {$token} + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$n == 0} { + set state(state) body + if ![regexp -nocase ^text $state(type)] { + # Turn off conversions for non-text data + fconfigure $s -translation binary + } + } elseif {$n > 0} { + if [regexp -nocase {^content-type:(.+)$} $line x type] { + set state(type) [string trim $type] + } + if [regexp -nocase {^content-length:(.+)$} $line x length] { + set state(totalsize) [string trim $length] + } + if [regexp -nocase {^([^:]+):(.+)$} $line x key value] { + lappend state(meta) $key $value + } elseif {[regexp ^HTTP $line]} { + set state(http) $line + } + } + } else { + if [catch { +# if [info exists state(-image)] { +# $state(-image) config -channel $s +# } else + if {[info exists state(-channel)]} { + set n [copychannel $s $state(-channel) $state(-blocksize)] + } else { + set block [read $s $state(-blocksize)] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + } + } + if {$n >= 0} { + incr state(currentsize) $n + } + } err] { + set state(error) $err + http_reset $token + } else { + if [info exists state(-progress)] { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + } + } +} +proc http_wait {token} { + upvar #0 $token state + if {![info exists state(status)] || [string length $state(status)] == 0} { + vwait $token\(status) + } + return $state(status) +} + +# Call http_formatQuery with an even number of arguments, where the first is +# a name, the second is a value, the third is another name, and so on. + +proc http_formatQuery {args} { + set result "" + set sep "" + foreach i $args { + append result $sep [httpMapReply $i] + if {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# The spec says: "non-alphanumeric characters are replaced by '%HH'" +# 1 leave alphanumerics characters alone +# 2 Convert every other character to an array lookup +# 3 Escape constructs that are "special" to the tcl parser +# 4 "subst" the result, doing all the array substitutions + + proc httpMapReply {string} { + global httpFormMap + set alphanumeric a-zA-Z0-9 + if ![info exists httpFormMap] { + + for {set i 1} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match \[$alphanumeric\] $c]} { + set httpFormMap($c) %[format %.2x $i] + } + } + # These are handled specially + array set httpFormMap { + " " + \n %0d%0a + } + } + regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string + regsub -all \n $string {\\n} string + regsub -all \t $string {\\t} string + regsub -all {[][{})\\]\)} $string {\\&} string + return [subst $string] +} + +# Default proxy filter. + proc httpProxyRequired {host} { + global http + if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { + if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { + set http(-proxyport) 8080 + } + return [list $http(-proxyhost) $http(-proxyport)] + } else { + return {} + } +} --- electric-6.05.orig/lib/tcl/safeinit.tcl +++ electric-6.05/lib/tcl/safeinit.tcl @@ -0,0 +1,461 @@ +# safeinit.tcl -- +# +# This code runs in a master to manage a safe slave with Safe Tcl. +# See the safe.n man page for details. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) safeinit.tcl 1.38 97/06/20 12:57:39 + +# This procedure creates a safe slave, initializes it with the +# safe base and installs the aliases for the security policy mechanism. + +proc tcl_safeCreateInterp {slave} { + global auto_path + + # Create the slave. + interp create -safe $slave + + # Set its auto_path + interp eval $slave [list set auto_path $auto_path] + + # And initialize it. + return [tcl_safeInitInterp $slave] +} + +# This procedure applies the initializations to an already existing +# interpreter. It is useful when you want to enable an interpreter +# created with "interp create -safe" to use security policies. + +proc tcl_safeInitInterp {slave} { + upvar #0 tclSafe$slave state + global tcl_library tk_library auto_path tcl_platform + + # These aliases let the slave load files to define new commands + + interp alias $slave source {} tclSafeAliasSource $slave + interp alias $slave load {} tclSafeAliasLoad $slave + + # This alias lets the slave have access to a subset of the 'file' + # command functionality. + tclAliasSubset $slave file file dir.* join root.* ext.* tail \ + path.* split + + # This alias interposes on the 'exit' command and cleanly terminates + # the slave. + interp alias $slave exit {} tcl_safeDeleteInterp $slave + + # Source init.tcl into the slave, to get auto_load and other + # procedures defined: + + if {$tcl_platform(platform) == "macintosh"} { + if {[catch {interp eval $slave [list source -rsrc Init]}]} { + if {[catch {interp eval $slave \ + [list source [file join $tcl_library init.tcl]]}]} { + error "can't source init.tcl into slave $slave" + } + } + } else { + if {[catch {interp eval $slave \ + [list source [file join $tcl_library init.tcl]]}]} { + error "can't source init.tcl into slave $slave" + } + } + + # Loading packages into slaves is handled by their master. + # This is overloaded to deal with regular packages and security policies + + interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave + interp eval $slave {package unknown tclPkgUnknown} + + # We need a helper procedure to define a $dir variable and then + # do a source of the pkgIndex.tcl file + interp eval $slave \ + [list proc tclPkgSource {dir args} { + if {[llength $args] == 2} { + source [lindex $args 0] [lindex $args 1] + } else { + source [lindex $args 0] + } + }] + + # Let the slave inherit a few variables + foreach varName \ + {tcl_library tcl_version tcl_patchLevel \ + tcl_platform(platform) auto_path} { + upvar #0 $varName var + interp eval $slave [list set $varName $var] + } + + # Other variables are predefined with set values + foreach {varName value} { + auto_noexec 1 + errorCode {} + errorInfo {} + env() {} + argv0 {} + argv {} + argc 0 + tcl_interactive 0 + } { + interp eval $slave [list set $varName $value] + } + + # If auto_path is not set in the slave, set it to empty so it has + # a value and exists. Otherwise auto_loading and package require + # will complain. + + interp eval $slave { + if {![info exists auto_path]} { + set auto_path {} + } + } + + # If we have Tk, make the slave have the same library as us: + + if {[info exists tk_library]} { + interp eval $slave [list set tk_library $tk_library] + } + + # Stub out auto-exec mechanism in slave + interp eval $slave [list proc auto_execok {name} {return {}}] + + return $slave +} + +# This procedure deletes a safe slave managed by Safe Tcl and +# cleans up associated state: + +proc tcl_safeDeleteInterp {slave args} { + upvar #0 tclSafe$slave state + + # If the slave has a policy loaded, clean it up now. + if {[info exists state(policyLoaded)]} { + set policy $state(policyLoaded) + set proc ${policy}_PolicyCleanup + if {[string compare [info proc $proc] $proc] == 0} { + $proc $slave + } + } + + # Discard the global array of state associated with the slave, and + # delete the interpreter. + catch {unset state} + catch {interp delete $slave} + + return +} + +# This procedure computes the global security policy search path. + +proc tclSafeComputePolicyPath {} { + global auto_path tclSafeAutoPathComputed tclSafePolicyPath + + set recompute 0 + if {(![info exists tclSafePolicyPath]) || + ("$tclSafePolicyPath" == "")} { + set tclSafePolicyPath "" + set tclSafeAutoPathComputed "" + set recompute 1 + } + if {"$tclSafeAutoPathComputed" != "$auto_path"} { + set recompute 1 + set tclSafeAutoPathComputed $auto_path + } + if {$recompute == 1} { + set tclSafePolicyPath "" + foreach i $auto_path { + lappend tclSafePolicyPath [file join $i policies] + } + } + return $tclSafePolicyPath +} + +# --------------------------------------------------------------------------- +# --------------------------------------------------------------------------- + +# tclSafeAliasSource is the target of the "source" alias in safe interpreters. + +proc tclSafeAliasSource {slave args} { + global auto_path errorCode errorInfo + + if {[llength $args] == 2} { + if {[string compare "-rsrc" [lindex $args 0]] != 0} { + return -code error "incorrect arguments to source" + } + if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \ + msg]} { + return -code error $msg + } + } else { + set file [lindex $args 0] + if {[catch {tclFileInPath $file $auto_path $slave} msg]} { + return -code error "permission denied" + } + set errorInfo "" + if {[catch {interp invokehidden $slave source $file} msg]} { + return -code error $msg + } + } + return $msg +} + +# tclSafeAliasLoad is the target of the "load" alias in safe interpreters. + +proc tclSafeAliasLoad {slave file args} { + global auto_path + + if {[llength $args] == 2} { + # Trying to load into another interpreter + # Allow this for a child of the slave, or itself + set other [lindex $args 1] + foreach x $slave y $other { + if {[string length $x] == 0} { + break + } elseif {[string compare $x $y] != 0} { + return -code error "permission denied" + } + } + set slave $other + } + + if {[string length $file] && \ + [catch {tclFileInPath $file $auto_path $slave} msg]} { + return -code error "permission denied" + } + if {[catch { + switch [llength $args] { + 0 { + interp invokehidden $slave load $file + } + 1 - + 2 { + interp invokehidden $slave load $file [lindex $args 0] + } + default { + error "too many arguments to load" + } + } + } msg]} { + return -code error $msg + } + return $msg +} + +# tclFileInPath raises an error if the file is not found in +# the list of directories contained in path. + +proc tclFileInPath {file path slave} { + set realcheckpath [tclSafeCheckAutoPath $path $slave] + set pwd [pwd] + if {[file isdirectory $file]} { + error "$file: not found" + } + set parent [file dirname $file] + if {[catch {cd $parent} msg]} { + error "$file: not found" + } + set realfilepath [file split [pwd]] + foreach dir $realcheckpath { + set match 1 + foreach a [file split $dir] b $realfilepath { + if {[string length $a] == 0} { + break + } elseif {[string compare $a $b] != 0} { + set match 0 + break + } + } + if {$match} { + cd $pwd + return 1 + } + } + cd $pwd + error "$file: not found" +} + +# This procedure computes our expanded copy of the path, as needed. +# It returns the path after expanding out all aliases. + +proc tclSafeCheckAutoPath {path slave} { + global auto_path + upvar #0 tclSafe$slave state + + if {![info exists state(expanded_auto_path)]} { + # Compute for the first time: + set state(cached_auto_path) $path + } elseif {"$state(cached_auto_path)" != "$path"} { + # The value of our path changed, so recompute: + set state(cached_auto_path) $path + } else { + # No change: no need to recompute. + return $state(expanded_auto_path) + } + + set pwd [pwd] + set state(expanded_auto_path) "" + foreach dir $state(cached_auto_path) { + if {![catch {cd $dir}]} { + lappend state(expanded_auto_path) [pwd] + } + } + cd $pwd + return $state(expanded_auto_path) +} + +proc tclSafeAliasPkgUnknown {slave package version {exact {}}} { + tclSafeLoadPkg $slave $package $version $exact +} + +proc tclSafeLoadPkg {slave package version exact} { + if {[string length $version] == 0} { + set version 1.0 + } + tclSafeLoadPkgInternal $slave $package $version $exact 0 +} + +proc tclSafeLoadPkgInternal {slave package version exact round} { + global auto_path + upvar #0 tclSafe$slave state + + # Search the policy path again; it might have changed in the meantime. + + if {$round == 1} { + tclSafeResearchPolicyPath + + if {[tclSafeLoadPolicy $slave $package $version]} { + return + } + } + + # Try to load as a policy. + + if [tclSafeLoadPolicy $slave $package $version] { + return + } + + # The package is not a security policy, so do the regular setup. + + # Here we run tclPkgUnknown in the master, but we hijack + # the source command so the setup ends up happening in the slave. + + rename source source.orig + proc source {args} "upvar dir dir + interp eval [list $slave] tclPkgSource \[list \$dir\] \$args" + + if [catch {tclPkgUnknown $package $version $exact} err] { + global errorInfo + + rename source {} + rename source.orig source + + error "$err\n$errorInfo" + } + rename source {} + rename source.orig source + + # If we are in the first round, check if the package + # is now known in the slave: + + if {$round == 0} { + set ifneeded \ + [interp eval $slave [list package ifneeded $package $version]] + + if {"$ifneeded" == ""} { + return [tclSafeLoadPkgInternal $slave $package $version $exact 1] + } + } +} + +proc tclSafeResearchPolicyPath {} { + global tclSafePolicyPath auto_index auto_path + + # If there was no change, do not search again. + + if {![info exists tclSafePolicyPath]} { + set tclSafePolicyPath "" + } + set oldPolicyPath $tclSafePolicyPath + set newPolicyPath [tclSafeComputePolicyPath] + if {"$newPolicyPath" == "$oldPolicyPath"} { + return + } + + # Loop through the path from back to front so early directories + # end up overriding later directories. This code is like auto_load, + # but only new-style tclIndex files (version 2) are supported. + + for {set i [expr [llength $newPolicyPath] - 1]} \ + {$i >= 0} \ + {incr i -1} { + set dir [lindex $newPolicyPath $i] + set file [file join $dir tclIndex] + if {[file exists $file]} { + if {[catch {source $file} msg]} { + puts stderr "error sourcing $file: $msg" + } + } + foreach file [lsort [glob -nocomplain [file join $dir *]]] { + if {[file isdir $file]} { + set dir $file + set file [file join $file tclIndex] + if {[file exists $file]} { + if {[catch {source $file} msg]} { + puts stderr "error sourcing $file: $msg" + } + } + } + } + } +} + +proc tclSafeLoadPolicy {slave package version} { + upvar #0 tclSafe$slave state + global auto_index + + set proc ${package}_PolicyInit + + if {[info command $proc] == "$proc" || + [info exists auto_index($proc)]} { + if [info exists state(policyLoaded)] { + error "security policy $state(policyLoaded) already loaded" + } + $proc $slave $version + interp eval $slave [list package provide $package $version] + set state(policyLoaded) $package + return 1 + } else { + return 0 + } +} +# This procedure enables access from a safe interpreter to only a subset of +# the subcommands of a command: + +proc tclSafeSubset {command okpat args} { + set subcommand [lindex $args 0] + if {[regexp $okpat $subcommand]} { + return [eval {$command $subcommand} [lrange $args 1 end]] + } + error "not allowed to invoke subcommand $subcommand of $command" +} + +# This procedure installs an alias in a slave that invokes "safesubset" +# in the master to execute allowed subcommands. It precomputes the pattern +# of allowed subcommands; you can use wildcards in the pattern if you wish +# to allow subcommand abbreviation. +# +# Syntax is: tclAliasSubset slave alias target subcommand1 subcommand2... + +proc tclAliasSubset {slave alias target args} { + set pat ^(; set sep "" + foreach sub $args { + append pat $sep$sub + set sep | + } + append pat )\$ + interp alias $slave $alias {} tclSafeSubset $target $pat +} --- electric-6.05.orig/lib/tcl/word.tcl +++ electric-6.05/lib/tcl/word.tcl @@ -0,0 +1,135 @@ +# word.tcl -- +# +# This file defines various procedures for computing word boundaries +# in strings. This file is primarily needed so Tk text and entry +# widgets behave properly for different platforms. +# +# Copyright (c) 1996 by Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) word.tcl 1.2 96/11/20 14:07:22 +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# The following variables are used to determine which characters are +# interpreted as white space. + +if {$tcl_platform(platform) == "windows"} { + # Windows style - any but space, tab, or newline + set tcl_wordchars "\[^ \t\n\]" + set tcl_nonwordchars "\[ \t\n\]" +} else { + # Motif style - any number, letter, or underscore + set tcl_wordchars {[a-zA-Z0-9_]} + set tcl_nonwordchars {[^a-zA-Z0-9_]} +} + +# tcl_wordBreakAfter -- +# +# This procedure returns the index of the first word boundary +# after the starting point in the given string, or -1 if there +# are no more boundaries in the given string. The index returned refers +# to the first character of the pair that comprises a boundary. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_wordBreakAfter {str start} { + global tcl_nonwordchars tcl_wordchars + set str [string range $str $start end] + if [regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result] { + return [expr [lindex $result 1] + $start] + } + return -1 +} + +# tcl_wordBreakBefore -- +# +# This procedure returns the index of the first word boundary +# before the starting point in the given string, or -1 if there +# are no more boundaries in the given string. The index returned +# refers to the second character of the pair that comprises a boundary. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_wordBreakBefore {str start} { + global tcl_nonwordchars tcl_wordchars + if {[string compare $start end] == 0} { + set start [string length $str] + } + if [regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result] { + return [lindex $result 1] + } + return -1 +} + +# tcl_endOfWord -- +# +# This procedure returns the index of the first end-of-word location +# after a starting index in the given string. An end-of-word location +# is defined to be the first whitespace character following the first +# non-whitespace character after the starting point. Returns -1 if +# there are no more words after the starting point. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_endOfWord {str start} { + global tcl_nonwordchars tcl_wordchars + if [regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \ + [string range $str $start end] result] { + return [expr [lindex $result 1] + $start] + } + return -1 +} + +# tcl_startOfNextWord -- +# +# This procedure returns the index of the first start-of-word location +# after a starting index in the given string. A start-of-word +# location is defined to be a non-whitespace character following a +# whitespace character. Returns -1 if there are no more start-of-word +# locations after the starting point. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_startOfNextWord {str start} { + global tcl_nonwordchars tcl_wordchars + if [regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \ + [string range $str $start end] result] { + return [expr [lindex $result 1] + $start] + } + return -1 +} + +# tcl_startOfPreviousWord -- +# +# This procedure returns the index of the first start-of-word location +# before a starting index in the given string. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_startOfPreviousWord {str start} { + global tcl_nonwordchars tcl_wordchars + if {[string compare $start end] == 0} { + set start [string length $str] + } + if [regexp -indices \ + "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \ + [string range $str 0 [expr $start - 1]] result word] { + return [lindex $word 0] + } + return -1 +} --- electric-6.05.orig/lib/tcl/opt0.1/pkgIndex.tcl +++ electric-6.05/lib/tcl/opt0.1/pkgIndex.tcl @@ -0,0 +1,7 @@ +# Tcl package index file, version 1.0 +# This file is NOT generated by the "pkg_mkIndex" command +# because if someone just did "package require opt", let's just load +# the package now, so they can readily use it +# and even "namespace import tcl::*" ... +# (tclPkgSetup just makes things slow and do not work so well with namespaces) +package ifneeded opt 0.2 [list source [file join $dir optparse.tcl]] --- electric-6.05.orig/lib/tcl/opt0.1/optparse.tcl +++ electric-6.05/lib/tcl/opt0.1/optparse.tcl @@ -0,0 +1,1094 @@ +# optparse.tcl -- +# +# (Private) option parsing package +# +# This might be documented and exported in 8.1 +# and some function hopefully moved to the C core for +# efficiency, if there is enough demand. (mail! ;-) +# +# Author: Laurent Demailly - Laurent.Demailly@sun.com - dl@mail.box.eu.org +# +# Credits: +# this is a complete 'over kill' rewrite by me, from a version +# written initially with Brent Welch, itself initially +# based on work with Steve Uhler. Thanks them ! +# +# SCCS: @(#) optparse.tcl 1.13 97/08/21 11:50:42 + +package provide opt 0.2 + +namespace eval ::tcl { + + # Exported APIs + namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ + OptProc OptProcArgGiven OptParse \ + Lassign Lvarpop Lvarset Lvarincr Lfirst \ + SetMax SetMin + + +################# Example of use / 'user documentation' ################### + + proc OptCreateTestProc {} { + + # Defines ::tcl::OptParseTest as a test proc with parsed arguments + # (can't be defined before the code below is loaded (before "OptProc")) + + # Every OptProc give usage information on "procname -help". + # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and + # then other arguments. + # + # example of 'valid' call: + # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ + # -nostatics false ch1 + OptProc OptParseTest { + {subcommand -choice {save print} "sub command"} + {arg1 3 "some number"} + {-aflag} + {-intflag 7} + {-weirdflag "help string"} + {-noStatics "Not ok to load static packages"} + {-nestedloading1 true "OK to load into nested slaves"} + {-nestedloading2 -boolean true "OK to load into nested slaves"} + {-libsOK -choice {Tk SybTcl} + "List of packages that can be loaded"} + {-precision -int 12 "Number of digits of precision"} + {-intval 7 "An integer"} + {-scale -float 1.0 "Scale factor"} + {-zoom 1.0 "Zoom factor"} + {-arbitrary foobar "Arbitrary string"} + {-random -string 12 "Random string"} + {-listval -list {} "List value"} + {-blahflag -blah abc "Funny type"} + {arg2 -boolean "a boolean"} + {arg3 -choice "ch1 ch2"} + {?optarg? -list {} "optional argument"} + } { + foreach v [info locals] { + puts stderr [format "%14s : %s" $v [set $v]] + } + } + } + +################### No User serviceable part below ! ############### +# You should really not look any further : +# The following is private unexported undocumented unblessed... code +# time to hit "q" ;-) ! + +# Hmmm... ok, you really want to know ? + +# You've been warned... Here it is... + + # Array storing the parsed descriptions + variable OptDesc; + array set OptDesc {}; + # Next potentially free key id (numeric) + variable OptDescN 0; + +# Inside algorithm/mechanism description: +# (not for the faint hearted ;-) +# +# The argument description is parsed into a "program tree" +# It is called a "program" because it is the program used by +# the state machine interpreter that use that program to +# actually parse the arguments at run time. +# +# The general structure of a "program" is +# notation (pseudo bnf like) +# name :== definition defines "name" as being "definition" +# { x y z } means list of x, y, and z +# x* means x repeated 0 or more time +# x+ means "x x*" +# x? means optionally x +# x | y means x or y +# "cccc" means the literal string +# +# program :== { programCounter programStep* } +# +# programStep :== program | singleStep +# +# programCounter :== {"P" integer+ } +# +# singleStep :== { instruction parameters* } +# +# instruction :== single element list +# +# (the difference between singleStep and program is that \ +# llength [Lfirst $program] >= 2 +# while +# llength [Lfirst $singleStep] == 1 +# ) +# +# And for this application: +# +# singleStep :== { instruction varname {hasBeenSet currentValue} type +# typeArgs help } +# instruction :== "flags" | "value" +# type :== knowType | anyword +# knowType :== "string" | "int" | "boolean" | "boolflag" | "float" +# | "choice" +# +# for type "choice" typeArgs is a list of possible choices, the first one +# is the default value. for all other types the typeArgs is the default value +# +# a "boolflag" is the type for a flag whose presence or absence, without +# additional arguments means respectively true or false (default flag type). +# +# programCounter is the index in the list of the currently processed +# programStep (thus starting at 1 (0 is {"P" prgCounterValue}). +# If it is a list it points toward each currently selected programStep. +# (like for "flags", as they are optional, form a set and programStep). + +# Performance/Implementation issues +# --------------------------------- +# We use tcl lists instead of arrays because with tcl8.0 +# they should start to be much faster. +# But this code use a lot of helper procs (like Lvarset) +# which are quite slow and would be helpfully optimized +# for instance by being written in C. Also our struture +# is complex and there is maybe some places where the +# string rep might be calculated at great exense. to be checked. + +# +# Parse a given description and saves it here under the given key +# generate a unused keyid if not given +# +proc ::tcl::OptKeyRegister {desc {key ""}} { + variable OptDesc; + variable OptDescN; + if {[string compare $key ""] == 0} { + # in case a key given to us as a parameter was a number + while {[info exists OptDesc($OptDescN)]} {incr OptDescN} + set key $OptDescN; + incr OptDescN; + } + # program counter + set program [list [list "P" 1]]; + + # are we processing flags (which makes a single program step) + set inflags 0; + + set state {}; + + # flag used to detect that we just have a single (flags set) subprogram. + set empty 1; + + foreach item $desc { + if {$state == "args"} { + # more items after 'args'... + return -code error "'args' special argument must be the last one"; + } + set res [OptNormalizeOne $item]; + set state [Lfirst $res]; + if {$inflags} { + if {$state == "flags"} { + # add to 'subprogram' + lappend flagsprg $res; + } else { + # put in the flags + # structure for flag programs items is a list of + # {subprgcounter {prg flag 1} {prg flag 2} {...}} + lappend program $flagsprg; + # put the other regular stuff + lappend program $res; + set inflags 0; + set empty 0; + } + } else { + if {$state == "flags"} { + set inflags 1; + # sub program counter + first sub program + set flagsprg [list [list "P" 1] $res]; + } else { + lappend program $res; + set empty 0; + } + } + } + if {$inflags} { + if {$empty} { + # We just have the subprogram, optimize and remove + # unneeded level: + set program $flagsprg; + } else { + lappend program $flagsprg; + } + } + + set OptDesc($key) $program; + + return $key; +} + +# +# Free the storage for that given key +# +proc ::tcl::OptKeyDelete {key} { + variable OptDesc; + unset OptDesc($key); +} + + # Get the parsed description stored under the given key. + proc OptKeyGetDesc {descKey} { + variable OptDesc; + if {![info exists OptDesc($descKey)]} { + return -code error "Unknown option description key \"$descKey\""; + } + set OptDesc($descKey); + } + +# Parse entry point for ppl who don't want to register with a key, +# for instance because the description changes dynamically. +# (otherwise one should really use OptKeyRegister once + OptKeyParse +# as it is way faster or simply OptProc which does it all) +# Assign a temporary key, call OptKeyParse and then free the storage +proc ::tcl::OptParse {desc arglist} { + set tempkey [OptKeyRegister $desc]; + set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res]; + OptKeyDelete $tempkey; + return -code $ret $res; +} + +# Helper function, replacement for proc that both +# register the description under a key which is the name of the proc +# (and thus unique to that code) +# and add a first line to the code to call the OptKeyParse proc +# Stores the list of variables that have been actually given by the user +# (the other will be sets to their default value) +# into local variable named "Args". +proc ::tcl::OptProc {name desc body} { + set namespace [uplevel namespace current]; + if { ([string match $name "::*"]) + || ([string compare $namespace "::"]==0)} { + # absolute name or global namespace, name is the key + set key $name; + } else { + # we are relative to some non top level namespace: + set key "${namespace}::${name}"; + } + OptKeyRegister $desc $key; + uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]; + return $key; +} +# Check that a argument has been given +# assumes that "OptProc" has been used as it will check in "Args" list +proc ::tcl::OptProcArgGiven {argname} { + upvar Args alist; + expr {[lsearch $alist $argname] >=0} +} + + ####### + # Programs/Descriptions manipulation + + # Return the instruction word/list of a given step/(sub)program + proc OptInstr {lst} { + Lfirst $lst; + } + # Is a (sub) program or a plain instruction ? + proc OptIsPrg {lst} { + expr {[llength [OptInstr $lst]]>=2} + } + # Is this instruction a program counter or a real instr + proc OptIsCounter {item} { + expr {[Lfirst $item]=="P"} + } + # Current program counter (2nd word of first word) + proc OptGetPrgCounter {lst} { + Lget $lst {0 1} + } + # Current program counter (2nd word of first word) + proc OptSetPrgCounter {lstName newValue} { + upvar $lstName lst; + set lst [lreplace $lst 0 0 [concat "P" $newValue]]; + } + # returns a list of currently selected items. + proc OptSelection {lst} { + set res {}; + foreach idx [lrange [Lfirst $lst] 1 end] { + lappend res [Lget $lst $idx]; + } + return $res; + } + + # Advance to next description + proc OptNextDesc {descName} { + uplevel [list Lvarincr $descName {0 1}]; + } + + # Get the current description, eventually descend + proc OptCurDesc {descriptions} { + lindex $descriptions [OptGetPrgCounter $descriptions]; + } + # get the current description, eventually descend + # through sub programs as needed. + proc OptCurDescFinal {descriptions} { + set item [OptCurDesc $descriptions]; + # Descend untill we get the actual item and not a sub program + while {[OptIsPrg $item]} { + set item [OptCurDesc $item]; + } + return $item; + } + # Current final instruction adress + proc OptCurAddr {descriptions {start {}}} { + set adress [OptGetPrgCounter $descriptions]; + lappend start $adress; + set item [lindex $descriptions $adress]; + if {[OptIsPrg $item]} { + return [OptCurAddr $item $start]; + } else { + return $start; + } + } + # Set the value field of the current instruction + proc OptCurSetValue {descriptionsName value} { + upvar $descriptionsName descriptions + # get the current item full adress + set adress [OptCurAddr $descriptions]; + # use the 3th field of the item (see OptValue / OptNewInst) + lappend adress 2 + Lvarset descriptions $adress [list 1 $value]; + # ^hasBeenSet flag + } + + # empty state means done/paste the end of the program + proc OptState {item} { + Lfirst $item + } + + # current state + proc OptCurState {descriptions} { + OptState [OptCurDesc $descriptions]; + } + + ####### + # Arguments manipulation + + # Returns the argument that has to be processed now + proc OptCurrentArg {lst} { + Lfirst $lst; + } + # Advance to next argument + proc OptNextArg {argsName} { + uplevel [list Lvarpop $argsName]; + } + ####### + + + + + + # Loop over all descriptions, calling OptDoOne which will + # eventually eat all the arguments. + proc OptDoAll {descriptionsName argumentsName} { + upvar $descriptionsName descriptions + upvar $argumentsName arguments; +# puts "entered DoAll"; + # Nb: the places where "state" can be set are tricky to figure + # because DoOne sets the state to flagsValue and return -continue + # when needed... + set state [OptCurState $descriptions]; + # We'll exit the loop in "OptDoOne" or when state is empty. + while 1 { + set curitem [OptCurDesc $descriptions]; + # Do subprograms if needed, call ourselves on the sub branch + while {[OptIsPrg $curitem]} { + OptDoAll curitem arguments +# puts "done DoAll sub"; + # Insert back the results in current tree; + Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ + $curitem; + OptNextDesc descriptions; + set curitem [OptCurDesc $descriptions]; + set state [OptCurState $descriptions]; + } +# puts "state = \"$state\" - arguments=($arguments)"; + if {[Lempty $state]} { + # Nothing left to do, we are done in this branch: + break; + } + # The following statement can make us terminate/continue + # as it use return -code {break, continue, return and error} + # codes + OptDoOne descriptions state arguments; + # If we are here, no special return code where issued, + # we'll step to next instruction : +# puts "new state = \"$state\""; + OptNextDesc descriptions; + set state [OptCurState $descriptions]; + } + if {![Lempty $arguments]} { + return -code error [OptTooManyArgs $descriptions $arguments]; + } + } + + # Process one step for the state machine, + # eventually consuming the current argument. + proc OptDoOne {descriptionsName stateName argumentsName} { + upvar $argumentsName arguments; + upvar $descriptionsName descriptions; + upvar $stateName state; + + # the special state/instruction "args" eats all + # the remaining args (if any) + if {($state == "args")} { + OptCurSetValue descriptions $arguments; + set arguments {}; +# puts "breaking out ('args' state: consuming every reminding args)" + return -code break; + } + + if {[Lempty $arguments]} { + if {$state == "flags"} { + # no argument and no flags : we're done +# puts "returning to previous (sub)prg (no more args)"; + return -code return; + } elseif {$state == "optValue"} { + set state next; # not used, for debug only + # go to next state + return ; + } else { + return -code error [OptMissingValue $descriptions]; + } + } else { + set arg [OptCurrentArg $arguments]; + } + + switch $state { + flags { + # A non-dash argument terminates the options, as does -- + + # Still a flag ? + if {![OptIsFlag $arg]} { + # don't consume the argument, return to previous prg + return -code return; + } + # consume the flag + OptNextArg arguments; + if {[string compare "--" $arg] == 0} { + # return from 'flags' state + return -code return; + } + + set hits [OptHits descriptions $arg]; + if {$hits > 1} { + return -code error [OptAmbigous $descriptions $arg] + } elseif {$hits == 0} { + return -code error [OptFlagUsage $descriptions $arg] + } + set item [OptCurDesc $descriptions]; + if {[OptNeedValue $item]} { + # we need a value, next state is + set state flagValue; + } else { + OptCurSetValue descriptions 1; + } + # continue + return -code continue; + } + flagValue - + value { + set item [OptCurDesc $descriptions]; + # Test the values against their required type + if [catch {OptCheckType $arg\ + [OptType $item] [OptTypeArgs $item]} val] { + return -code error [OptBadValue $item $arg $val] + } + # consume the value + OptNextArg arguments; + # set the value + OptCurSetValue descriptions $val; + # go to next state + if {$state == "flagValue"} { + set state flags + return -code continue; + } else { + set state next; # not used, for debug only + return ; # will go on next step + } + } + optValue { + set item [OptCurDesc $descriptions]; + # Test the values against their required type + if ![catch {OptCheckType $arg\ + [OptType $item] [OptTypeArgs $item]} val] { + # right type, so : + # consume the value + OptNextArg arguments; + # set the value + OptCurSetValue descriptions $val; + } + # go to next state + set state next; # not used, for debug only + return ; # will go on next step + } + } + # If we reach this point: an unknown + # state as been entered ! + return -code error "Bug! unknown state in DoOne \"$state\"\ + (prg counter [OptGetPrgCounter $descriptions]:\ + [OptCurDesc $descriptions])"; + } + +# Parse the options given the key to previously registered description +# and arguments list +proc ::tcl::OptKeyParse {descKey arglist} { + + set desc [OptKeyGetDesc $descKey]; + + # make sure -help always give usage + if {[string compare "-help" [string tolower $arglist]] == 0} { + return -code error [OptError "Usage information:" $desc 1]; + } + + OptDoAll desc arglist; + + # Analyse the result + # Walk through the tree: + OptTreeVars $desc "#[expr [info level]-1]" ; +} + + # determine string length for nice tabulated output + proc OptTreeVars {desc level {vnamesLst {}}} { + foreach item $desc { + if {[OptIsCounter $item]} continue; + if {[OptIsPrg $item]} { + set vnamesLst [OptTreeVars $item $level $vnamesLst]; + } else { + set vname [OptVarName $item]; + upvar $level $vname var + if {[OptHasBeenSet $item]} { +# puts "adding $vname" + # lets use the input name for the returned list + # it is more usefull, for instance you can check that + # no flags at all was given with expr + # {![string match "*-*" $Args]} + lappend vnamesLst [OptName $item]; + set var [OptValue $item]; + } else { + set var [OptDefaultValue $item]; + } + } + } + return $vnamesLst + } + + +# Check the type of a value +# and emit an error if arg is not of the correct type +# otherwise returns the canonical value of that arg (ie 0/1 for booleans) +proc ::tcl::OptCheckType {arg type {typeArgs ""}} { +# puts "checking '$arg' against '$type' ($typeArgs)"; + + # only types "any", "choice", and numbers can have leading "-" + + switch -exact -- $type { + int { + if ![regexp {^(-+)?[0-9]+$} $arg] { + error "not an integer" + } + return $arg; + } + float { + return [expr double($arg)] + } + script - + list { + # if llength fail : malformed list + if {[llength $arg]==0} { + if {[OptIsFlag $arg]} { + error "no values with leading -" + } + } + return $arg; + } + boolean { + if ![regexp -nocase {^(true|false|0|1)$} $arg] { + error "non canonic boolean" + } + # convert true/false because expr/if is broken with "!,... + if {$arg} { + return 1 + } else { + return 0 + } + } + choice { + if {[lsearch -exact $typeArgs $arg] < 0} { + error "invalid choice" + } + return $arg; + } + any { + return $arg; + } + string - + default { + if {[OptIsFlag $arg]} { + error "no values with leading -" + } + return $arg + } + } + return neverReached; +} + + # internal utilities + + # returns the number of flags matching the given arg + # sets the (local) prg counter to the list of matches + proc OptHits {descName arg} { + upvar $descName desc; + set hits 0 + set hitems {} + set i 1; + + set larg [string tolower $arg]; + set len [string length $larg]; + set last [expr $len-1]; + + foreach item [lrange $desc 1 end] { + set flag [OptName $item] + # lets try to match case insensitively + # (string length ought to be cheap) + set lflag [string tolower $flag]; + if {$len == [string length $lflag]} { + if {[string compare $larg $lflag]==0} { + # Exact match case + OptSetPrgCounter desc $i; + return 1; + } + } else { + if {[string compare $larg [string range $lflag 0 $last]]==0} { + lappend hitems $i; + incr hits; + } + } + incr i; + } + if {$hits} { + OptSetPrgCounter desc $hitems; + } + return $hits + } + + # Extract fields from the list structure: + + proc OptName {item} { + lindex $item 1; + } + # + proc OptHasBeenSet {item} { + Lget $item {2 0}; + } + # + proc OptValue {item} { + Lget $item {2 1}; + } + + proc OptIsFlag {name} { + string match "-*" $name; + } + proc OptIsOpt {name} { + string match {\?*} $name; + } + proc OptVarName {item} { + set name [OptName $item]; + if {[OptIsFlag $name]} { + return [string range $name 1 end]; + } elseif {[OptIsOpt $name]} { + return [string trim $name "?"]; + } else { + return $name; + } + } + proc OptType {item} { + lindex $item 3 + } + proc OptTypeArgs {item} { + lindex $item 4 + } + proc OptHelp {item} { + lindex $item 5 + } + proc OptNeedValue {item} { + string compare [OptType $item] boolflag + } + proc OptDefaultValue {item} { + set val [OptTypeArgs $item] + switch -exact -- [OptType $item] { + choice {return [lindex $val 0]} + boolean - + boolflag { + # convert back false/true to 0/1 because expr !$bool + # is broken.. + if {$val} { + return 1 + } else { + return 0 + } + } + } + return $val + } + + # Description format error helper + proc OptOptUsage {item {what ""}} { + return -code error "invalid description format$what: $item\n\ + should be a list of {varname|-flagname ?-type? ?defaultvalue?\ + ?helpstring?}"; + } + + + # Generate a canonical form single instruction + proc OptNewInst {state varname type typeArgs help} { + list $state $varname [list 0 {}] $type $typeArgs $help; + # ^ ^ + # | | + # hasBeenSet=+ +=currentValue + } + + # Translate one item to canonical form + proc OptNormalizeOne {item} { + set lg [Lassign $item varname arg1 arg2 arg3]; +# puts "called optnormalizeone '$item' v=($varname), lg=$lg"; + set isflag [OptIsFlag $varname]; + set isopt [OptIsOpt $varname]; + if {$isflag} { + set state "flags"; + } elseif {$isopt} { + set state "optValue"; + } elseif {[string compare $varname "args"]} { + set state "value"; + } else { + set state "args"; + } + + # apply 'smart' 'fuzzy' logic to try to make + # description writer's life easy, and our's difficult : + # let's guess the missing arguments :-) + + switch $lg { + 1 { + if {$isflag} { + return [OptNewInst $state $varname boolflag false ""]; + } else { + return [OptNewInst $state $varname any "" ""]; + } + } + 2 { + # varname default + # varname help + set type [OptGuessType $arg1] + if {[string compare $type "string"] == 0} { + if {$isflag} { + set type boolflag + set def false + } else { + set type any + set def "" + } + set help $arg1 + } else { + set help "" + set def $arg1 + } + return [OptNewInst $state $varname $type $def $help]; + } + 3 { + # varname type value + # varname value comment + + if [regexp {^-(.+)$} $arg1 x type] { + # flags/optValue as they are optional, need a "value", + # on the contrary, for a variable (non optional), + # default value is pointless, 'cept for choices : + if {$isflag || $isopt || ($type == "choice")} { + return [OptNewInst $state $varname $type $arg2 ""]; + } else { + return [OptNewInst $state $varname $type "" $arg2]; + } + } else { + return [OptNewInst $state $varname\ + [OptGuessType $arg1] $arg1 $arg2] + } + } + 4 { + if [regexp {^-(.+)$} $arg1 x type] { + return [OptNewInst $state $varname $type $arg2 $arg3]; + } else { + return -code error [OptOptUsage $item]; + } + } + default { + return -code error [OptOptUsage $item]; + } + } + } + + # Auto magic lasy type determination + proc OptGuessType {arg} { + if [regexp -nocase {^(true|false)$} $arg] { + return boolean + } + if [regexp {^(-+)?[0-9]+$} $arg] { + return int + } + if ![catch {expr double($arg)}] { + return float + } + return string + } + + # Error messages front ends + + proc OptAmbigous {desc arg} { + OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] + } + proc OptFlagUsage {desc arg} { + OptError "bad flag \"$arg\", must be one of" $desc; + } + proc OptTooManyArgs {desc arguments} { + OptError "too many arguments (unexpected argument(s): $arguments),\ + usage:"\ + $desc 1 + } + proc OptParamType {item} { + if {[OptIsFlag $item]} { + return "flag"; + } else { + return "parameter"; + } + } + proc OptBadValue {item arg {err {}}} { +# puts "bad val err = \"$err\""; + OptError "bad value \"$arg\" for [OptParamType $item]"\ + [list $item] + } + proc OptMissingValue {descriptions} { +# set item [OptCurDescFinal $descriptions]; + set item [OptCurDesc $descriptions]; + OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ + (use -help for full usage) :"\ + [list $item] + } + +proc ::tcl::OptKeyError {prefix descKey {header 0}} { + OptError $prefix [OptKeyGetDesc $descKey] $header; +} + + # determine string length for nice tabulated output + proc OptLengths {desc nlName tlName dlName} { + upvar $nlName nl; + upvar $tlName tl; + upvar $dlName dl; + foreach item $desc { + if {[OptIsCounter $item]} continue; + if {[OptIsPrg $item]} { + OptLengths $item nl tl dl + } else { + SetMax nl [string length [OptName $item]] + SetMax tl [string length [OptType $item]] + set dv [OptTypeArgs $item]; + if {[OptState $item] != "header"} { + set dv "($dv)"; + } + set l [string length $dv]; + # limit the space allocated to potentially big "choices" + if {([OptType $item] != "choice") || ($l<=12)} { + SetMax dl $l + } else { + if {![info exists dl]} { + set dl 0 + } + } + } + } + } + # output the tree + proc OptTree {desc nl tl dl} { + set res ""; + foreach item $desc { + if {[OptIsCounter $item]} continue; + if {[OptIsPrg $item]} { + append res [OptTree $item $nl $tl $dl]; + } else { + set dv [OptTypeArgs $item]; + if {[OptState $item] != "header"} { + set dv "($dv)"; + } + append res [format "\n %-*s %-*s %-*s %s" \ + $nl [OptName $item] $tl [OptType $item] \ + $dl $dv [OptHelp $item]] + } + } + return $res; + } + +# Give nice usage string +proc ::tcl::OptError {prefix desc {header 0}} { + # determine length + if {$header} { + # add faked instruction + set h [list [OptNewInst header Var/FlagName Type Value Help]]; + lappend h [OptNewInst header ------------ ---- ----- ----]; + lappend h [OptNewInst header {( -help} "" "" {gives this help )}] + set desc [concat $h $desc] + } + OptLengths $desc nl tl dl + # actually output + return "$prefix[OptTree $desc $nl $tl $dl]" +} + + +################ General Utility functions ####################### + +# +# List utility functions +# Naming convention: +# "Lvarxxx" take the list VARiable name as argument +# "Lxxxx" take the list value as argument +# (which is not costly with Tcl8 objects system +# as it's still a reference and not a copy of the values) +# + +# Is that list empty ? +proc ::tcl::Lempty {list} { + expr {[llength $list]==0} +} + +# Gets the value of one leaf of a lists tree +proc ::tcl::Lget {list indexLst} { + if {[llength $indexLst] <= 1} { + return [lindex $list $indexLst]; + } + Lget [lindex $list [Lfirst $indexLst]] [Lrest $indexLst]; +} +# Sets the value of one leaf of a lists tree +# (we use the version that does not create the elements because +# it would be even slower... needs to be written in C !) +# (nb: there is a non trivial recursive problem with indexes 0, +# which appear because there is no difference between a list +# of 1 element and 1 element alone : [list "a"] == "a" while +# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 +# and [listp "a b"] maybe 0. listp does not exist either...) +proc ::tcl::Lvarset {listName indexLst newValue} { + upvar $listName list; + if {[llength $indexLst] <= 1} { + Lvarset1nc list $indexLst $newValue; + } else { + set idx [Lfirst $indexLst]; + set targetList [lindex $list $idx]; + # reduce refcount on targetList (not really usefull now, + # could be with optimizing compiler) +# Lvarset1 list $idx {}; + # recursively replace in targetList + Lvarset targetList [Lrest $indexLst] $newValue; + # put updated sub list back in the tree + Lvarset1nc list $idx $targetList; + } +} +# Set one cell to a value, eventually create all the needed elements +# (on level-1 of lists) +variable emptyList {} +proc ::tcl::Lvarset1 {listName index newValue} { + upvar $listName list; + if {$index < 0} {return -code error "invalid negative index"} + set lg [llength $list]; + if {$index >= $lg} { + variable emptyList; + for {set i $lg} {$i<$index} {incr i} { + lappend list $emptyList; + } + lappend list $newValue; + } else { + set list [lreplace $list $index $index $newValue]; + } +} +# same as Lvarset1 but no bound checking / creation +proc ::tcl::Lvarset1nc {listName index newValue} { + upvar $listName list; + set list [lreplace $list $index $index $newValue]; +} +# Increments the value of one leaf of a lists tree +# (which must exists) +proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { + upvar $listName list; + if {[llength $indexLst] <= 1} { + Lvarincr1 list $indexLst $howMuch; + } else { + set idx [Lfirst $indexLst]; + set targetList [lindex $list $idx]; + # reduce refcount on targetList + Lvarset1nc list $idx {}; + # recursively replace in targetList + Lvarincr targetList [Lrest $indexLst] $howMuch; + # put updated sub list back in the tree + Lvarset1nc list $idx $targetList; + } +} +# Increments the value of one cell of a list +proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { + upvar $listName list; + set newValue [expr [lindex $list $index]+$howMuch]; + set list [lreplace $list $index $index $newValue]; + return $newValue; +} +# Returns the first element of a list +proc ::tcl::Lfirst {list} { + lindex $list 0 +} +# Returns the rest of the list minus first element +proc ::tcl::Lrest {list} { + lrange $list 1 end +} +# Removes the first element of a list +proc ::tcl::Lvarpop {listName} { + upvar $listName list; + set list [lrange $list 1 end]; +} +# Same but returns the removed element +proc ::tcl::Lvarpop2 {listName} { + upvar $listName list; + set el [Lfirst $list]; + set list [lrange $list 1 end]; + return $el; +} +# Assign list elements to variables and return the length of the list +proc ::tcl::Lassign {list args} { + # faster than direct blown foreach (which does not byte compile) + set i 0; + set lg [llength $list]; + foreach vname $args { + if {$i>=$lg} break + uplevel [list set $vname [lindex $list $i]]; + incr i; + } + return $lg; +} + +# Misc utilities + +# Set the varname to value if value is greater than varname's current value +# or if varname is undefined +proc ::tcl::SetMax {varname value} { + upvar 1 $varname var + if {![info exists var] || $value > $var} { + set var $value + } +} + +# Set the varname to value if value is smaller than varname's current value +# or if varname is undefined +proc ::tcl::SetMin {varname value} { + upvar 1 $varname var + if {![info exists var] || $value < $var} { + set var $value + } +} + + + # everything loaded fine, lets create the test proc: + OptCreateTestProc + # Don't need the create temp proc anymore: + rename OptCreateTestProc {} +} --- electric-6.05.orig/lib/tcl/ldAout.tcl +++ electric-6.05/lib/tcl/ldAout.tcl @@ -0,0 +1,240 @@ +# ldAout.tcl -- +# +# This "tclldAout" procedure in this script acts as a replacement +# for the "ld" command when linking an object file that will be +# loaded dynamically into Tcl or Tk using pseudo-static linking. +# +# Parameters: +# The arguments to the script are the command line options for +# an "ld" command. +# +# Results: +# The "ld" command is parsed, and the "-o" option determines the +# module name. ".a" and ".o" options are accumulated. +# The input archives and object files are examined with the "nm" +# command to determine whether the modules initialization +# entry and safe initialization entry are present. A trivial +# C function that locates the entries is composed, compiled, and +# its .o file placed before all others in the command; then +# "ld" is executed to bind the objects together. +# +# SCCS: @(#) ldAout.tcl 1.12 96/11/30 17:11:02 +# +# Copyright (c) 1995, by General Electric Company. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This work was supported in part by the ARPA Manufacturing Automation +# and Design Engineering (MADE) Initiative through ARPA contract +# F33615-94-C-4400. + +proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} { + global env + global argv + + if {$cc==""} { + set cc $env(CC) + } + + # if only two parameters are supplied there is assumed that the + # only shlib_suffix is missing. This parameter is anyway available + # as "info sharedlibextension" too, so there is no need to transfer + # 3 parameters to the function tclLdAout. For compatibility, this + # function now accepts both 2 and 3 parameters. + + if {$shlib_suffix==""} { + set shlib_cflags $env(SHLIB_CFLAGS) + } else { + if {$shlib_cflags=="none"} { + set shlib_cflags $shlib_suffix + } + } + + # seenDotO is nonzero if a .o or .a file has been seen + + set seenDotO 0 + + # minusO is nonzero if the last command line argument was "-o". + + set minusO 0 + + # head has command line arguments up to but not including the first + # .o or .a file. tail has the rest of the arguments. + + set head {} + set tail {} + + # nmCommand is the "nm" command that lists global symbols from the + # object files. + + set nmCommand {|nm -g} + + # entryProtos is the table of _Init and _SafeInit prototypes found in the + # module. + + set entryProtos {} + + # entryPoints is the table of _Init and _SafeInit entries found in the + # module. + + set entryPoints {} + + # libraries is the list of -L and -l flags to the linker. + + set libraries {} + set libdirs {} + + # Process command line arguments + + foreach a $argv { + if {!$minusO && [regexp {\.[ao]$} $a]} { + set seenDotO 1 + lappend nmCommand $a + } + if {$minusO} { + set outputFile $a + set minusO 0 + } elseif {![string compare $a -o]} { + set minusO 1 + } + if [regexp {^-[lL]} $a] { + lappend libraries $a + if [regexp {^-L} $a] { + lappend libdirs [string range $a 2 end] + } + } elseif {$seenDotO} { + lappend tail $a + } else { + lappend head $a + } + } + lappend libdirs /lib /usr/lib + + # MIPS -- If there are corresponding G0 libraries, replace the + # ordinary ones with the G0 ones. + + set libs {} + foreach lib $libraries { + if [regexp {^-l} $lib] { + set lname [string range $lib 2 end] + foreach dir $libdirs { + if [file exists [file join $dir lib${lname}_G0.a]] { + set lname ${lname}_G0 + break + } + } + lappend libs -l$lname + } else { + lappend libs $lib + } + } + set libraries $libs + + # Extract the module name from the "-o" option + + if {![info exists outputFile]} { + error "-o option must be supplied to link a Tcl load module" + } + set m [file tail $outputFile] + if [regexp {\.a$} $outputFile] { + set shlib_suffix .a + } else { + set shlib_suffix "" + } + if [regexp {\..*$} $outputFile match] { + set l [expr [string length $m] - [string length $match]] + } else { + error "Output file does not appear to have a suffix" + } + set modName [string tolower [string range $m 0 [expr $l-1]]] + if [regexp {^lib} $modName] { + set modName [string range $modName 3 end] + } + if [regexp {[0-9\.]*(_g0)?$} $modName match] { + set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]] + } + set modName "[string toupper [string index $modName 0]][string range $modName 1 end]" + + # Catalog initialization entry points found in the module + + set f [open $nmCommand r] + while {[gets $f l] >= 0} { + if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] { + if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} { + set s $symbol + } + append entryProtos {extern int } $symbol { (); } \n + append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n + } + } + close $f + + if {$entryPoints==""} { + error "No entry point found in objects" + } + + # Compose a C function that resolves the initialization entry points and + # embeds the required libraries in the object code. + + set C {#include } + append C \n + append C {char TclLoadLibraries_} $modName { [] =} \n + append C { "@LIBS: } $libraries {";} \n + append C $entryProtos + append C {static struct } \{ \n + append C { char * name;} \n + append C { int (*value)();} \n + append C \} {dictionary [] = } \{ \n + append C $entryPoints + append C { 0, 0 } \n \} \; \n + append C {typedef struct Tcl_Interp Tcl_Interp;} \n + append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n + append C {Tcl_PackageInitProc *} \n + append C TclLoadDictionary_ $modName { (symbol)} \n + append C { char * symbol;} \n + append C {{ + int i; + for (i = 0; dictionary [i] . name != 0; ++i) { + if (!strcmp (symbol, dictionary [i] . name)) { + return dictionary [i].value; + } + } + return 0; +}} \n + + # Write the C module and compile it + + set cFile tcl$modName.c + set f [open $cFile w] + puts -nonewline $f $C + close $f + set ccCommand "$cc -c $shlib_cflags $cFile" + puts stderr $ccCommand + eval exec $ccCommand + + # Now compose and execute the ld command that packages the module + + if {$shlib_suffix == ".a"} { + set ldCommand "ar cr $outputFile" + regsub { -o} $tail {} tail + } else { + set ldCommand ld + foreach item $head { + lappend ldCommand $item + } + } + lappend ldCommand tcl$modName.o + foreach item $tail { + lappend ldCommand $item + } + puts stderr $ldCommand + eval exec $ldCommand + if {$shlib_suffix == ".a"} { + exec ranlib $outputFile + } + + # Clean up working files + + exec /bin/rm $cFile [file rootname $cFile].o +} --- electric-6.05.orig/lib/tcl/http1.0/pkgIndex.tcl +++ electric-6.05/lib/tcl/http1.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}] --- electric-6.05.orig/lib/tcl/http1.0/http.tcl +++ electric-6.05/lib/tcl/http1.0/http.tcl @@ -0,0 +1,379 @@ +# http.tcl +# Client-side HTTP for GET, POST, and HEAD commands. +# These routines can be used in untrusted code that uses the Safesock +# security policy. +# These procedures use a callback interface to avoid using vwait, +# which is not defined in the safe base. +# +# SCCS: @(#) http.tcl 1.10 97/10/29 16:12:55 +# +# See the http.n man page for documentation + +package provide http 1.0 + +array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 1.0} + -proxyfilter httpProxyRequired +} +proc http_config {args} { + global http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {[regexp -- $pat $flag]} { + return $http($flag) + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } else { + foreach {flag value} $args { + if [regexp -- $pat $flag] { + set http($flag) $value + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } + } +} + + proc httpFinish { token {errormsg ""} } { + upvar #0 $token state + global errorInfo errorCode + if {[string length $errormsg] != 0} { + set state(error) [list $errormsg $errorInfo $errorCode] + set state(status) error + } + catch {close $state(sock)} + catch {after cancel $state(after)} + if {[info exists state(-command)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} +proc http_reset { token {why reset} } { + upvar #0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + httpFinish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } +} +proc http_get { url args } { + global http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token http#[incr http(uid)] + upvar #0 $token state + http_reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + set usage [join $options ", "] + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + foreach {flag value} $args { + if [regexp $pat $flag] { + # Validate numbers + if {[info exists state($flag)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + if {[string length $srvurl] == 0} { + set srvurl / + } + if {[string length $proto] == 0} { + set url http://$url + } + set state(url) $url + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http_reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # Send data in cr-lf format, but accept any line terminators + + fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) + + # The following is disallowed in safe interpreters, but the socket + # is already in non-blocking mode in that case. + + catch {fconfigure $s -blocking off} + set len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + puts $s "$how $srvurl HTTP/1.0" + puts $s "Accept: $http(-accept)" + puts $s "Host: $host" + puts $s "User-Agent: $http(-useragent)" + foreach {key value} $state(-headers) { + regsub -all \[\n\r\] $value {} value + set key [string trim $key] + if {[string length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list httpEvent $token] + if {! [info exists state(-command)]} { + http_wait $token + } + return $token +} +proc http_data {token} { + upvar #0 $token state + return $state(body) +} +proc http_status {token} { + upvar #0 $token state + return $state(status) +} +proc http_code {token} { + upvar #0 $token state + return $state(http) +} +proc http_size {token} { + upvar #0 $token state + return $state(currentsize) +} + + proc httpEvent {token} { + upvar #0 $token state + set s $state(sock) + + if [eof $s] then { + httpEof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$n == 0} { + set state(state) body + if ![regexp -nocase ^text $state(type)] { + # Turn off conversions for non-text data + fconfigure $s -translation binary + if {[info exists state(-channel)]} { + fconfigure $state(-channel) -translation binary + } + } + if {[info exists state(-channel)] && + ![info exists state(-handler)]} { + # Initiate a sequence of background fcopies + fileevent $s readable {} + httpCopyStart $s $token + } + } elseif {$n > 0} { + if [regexp -nocase {^content-type:(.+)$} $line x type] { + set state(type) [string trim $type] + } + if [regexp -nocase {^content-length:(.+)$} $line x length] { + set state(totalsize) [string trim $length] + } + if [regexp -nocase {^([^:]+):(.+)$} $line x key value] { + lappend state(meta) $key $value + } elseif {[regexp ^HTTP $line]} { + set state(http) $line + } + } + } else { + if [catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) {$s $token}] + } else { + set block [read $s $state(-blocksize)] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + } + } + if {$n >= 0} { + incr state(currentsize) $n + } + } err] { + httpFinish $token $err + } else { + if [info exists state(-progress)] { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + } + } +} + proc httpCopyStart {s token} { + upvar #0 $token state + if [catch { + fcopy $s $state(-channel) -size $state(-blocksize) -command \ + [list httpCopyDone $token] + } err] { + httpFinish $token $err + } +} + proc httpCopyDone {token count {error {}}} { + upvar #0 $token state + set s $state(sock) + incr state(currentsize) $count + if [info exists state(-progress)] { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + if {([string length $error] != 0)} { + httpFinish $token $error + } elseif {[eof $s]} { + httpEof $token + } else { + httpCopyStart $s $token + } +} + proc httpEof {token} { + upvar #0 $token state + if {$state(state) == "header"} { + # Premature eof + set state(status) eof + } else { + set state(status) ok + } + set state(state) eof + httpFinish $token +} +proc http_wait {token} { + upvar #0 $token state + if {![info exists state(status)] || [string length $state(status)] == 0} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + return $state(status) +} + +# Call http_formatQuery with an even number of arguments, where the first is +# a name, the second is a value, the third is another name, and so on. + +proc http_formatQuery {args} { + set result "" + set sep "" + foreach i $args { + append result $sep [httpMapReply $i] + if {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# The spec says: "non-alphanumeric characters are replaced by '%HH'" +# 1 leave alphanumerics characters alone +# 2 Convert every other character to an array lookup +# 3 Escape constructs that are "special" to the tcl parser +# 4 "subst" the result, doing all the array substitutions + + proc httpMapReply {string} { + global httpFormMap + set alphanumeric a-zA-Z0-9 + if ![info exists httpFormMap] { + + for {set i 1} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match \[$alphanumeric\] $c]} { + set httpFormMap($c) %[format %.2x $i] + } + } + # These are handled specially + array set httpFormMap { + " " + \n %0d%0a + } + } + regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string + regsub -all \n $string {\\n} string + regsub -all \t $string {\\t} string + regsub -all {[][{})\\]\)} $string {\\&} string + return [subst $string] +} + +# Default proxy filter. + proc httpProxyRequired {host} { + global http + if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { + if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { + set http(-proxyport) 8080 + } + return [list $http(-proxyhost) $http(-proxyport)] + } else { + return {} + } +} --- electric-6.05.orig/lib/tcl/http2.0/pkgIndex.tcl +++ electric-6.05/lib/tcl/http2.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded http 2.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}] --- electric-6.05.orig/lib/tcl/http2.0/http.tcl +++ electric-6.05/lib/tcl/http2.0/http.tcl @@ -0,0 +1,462 @@ +# http.tcl -- +# +# Client-side HTTP for GET, POST, and HEAD commands. +# These routines can be used in untrusted code that uses +# the Safesock security policy. These procedures use a +# callback interface to avoid using vwait, which is not +# defined in the safe base. +# +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30 + +package provide http 2.0 ;# This uses Tcl namespaces + +namespace eval http { + variable http + + array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 2.0} + -proxyfilter http::ProxyRequired + } + + variable formMap + set alphanumeric a-zA-Z0-9 + + for {set i 1} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match \[$alphanumeric\] $c]} { + set formMap($c) %[format %.2x $i] + } + } + # These are handled specially + array set formMap { + " " + \n %0d%0a + } + + namespace export geturl config reset wait formatQuery + # Useful, but not exported: data size status code +} + +# http::config -- +# +# See documentaion for details. +# +# Arguments: +# args Options parsed by the procedure. +# Results: +# TODO + +proc http::config {args} { + variable http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {[regexp -- $pat $flag]} { + return $http($flag) + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } else { + foreach {flag value} $args { + if [regexp -- $pat $flag] { + set http($flag) $value + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } + } +} + + proc http::Finish { token {errormsg ""} } { + variable $token + upvar 0 $token state + global errorInfo errorCode + if {[string length $errormsg] != 0} { + set state(error) [list $errormsg $errorInfo $errorCode] + set state(status) error + } + catch {close $state(sock)} + catch {after cancel $state(after)} + if {[info exists state(-command)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} + +# http::reset -- +# +# See documentaion for details. +# +# Arguments: +# token Connection token. +# why Status info. +# Results: +# TODO + +proc http::reset { token {why reset} } { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } +} + +# http::geturl -- +# +# Establishes a connection to a remote url via http. +# +# Arguments: +# url The http URL to goget. +# args Option value pairs. Valid options include: +# -blocksize, -validate, -headers, -timeout +# Results: +# Returns a token for this connection. + + +proc http::geturl { url args } { + variable http + if ![info exists http(uid)] { + set http(uid) 0 + } + set token [namespace current]::[incr http(uid)] + variable $token + upvar 0 $token state + reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + set usage [join $options ", "] + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + foreach {flag value} $args { + if [regexp $pat $flag] { + # Validate numbers + if {[info exists state($flag)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + if {[string length $srvurl] == 0} { + set srvurl / + } + if {[string length $proto] == 0} { + set url http://$url + } + set state(url) $url + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http::reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # Send data in cr-lf format, but accept any line terminators + + fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) + + # The following is disallowed in safe interpreters, but the socket + # is already in non-blocking mode in that case. + + catch {fconfigure $s -blocking off} + set len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + puts $s "$how $srvurl HTTP/1.0" + puts $s "Accept: $http(-accept)" + puts $s "Host: $host" + puts $s "User-Agent: $http(-useragent)" + foreach {key value} $state(-headers) { + regsub -all \[\n\r\] $value {} value + set key [string trim $key] + if {[string length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list http::Event $token] + if {! [info exists state(-command)]} { + wait $token + } + return $token +} + +# Data access functions: +# Data - the URL data +# Status - the transaction status: ok, reset, eof, timeout +# Code - the HTTP transaction code, e.g., 200 +# Size - the size of the URL data + +proc http::data {token} { + variable $token + upvar 0 $token state + return $state(body) +} +proc http::status {token} { + variable $token + upvar 0 $token state + return $state(status) +} +proc http::code {token} { + variable $token + upvar 0 $token state + return $state(http) +} +proc http::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} + + proc http::Event {token} { + variable $token + upvar 0 $token state + set s $state(sock) + + if [::eof $s] then { + Eof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$n == 0} { + set state(state) body + if ![regexp -nocase ^text $state(type)] { + # Turn off conversions for non-text data + fconfigure $s -translation binary + if {[info exists state(-channel)]} { + fconfigure $state(-channel) -translation binary + } + } + if {[info exists state(-channel)] && + ![info exists state(-handler)]} { + # Initiate a sequence of background fcopies + fileevent $s readable {} + CopyStart $s $token + } + } elseif {$n > 0} { + if [regexp -nocase {^content-type:(.+)$} $line x type] { + set state(type) [string trim $type] + } + if [regexp -nocase {^content-length:(.+)$} $line x length] { + set state(totalsize) [string trim $length] + } + if [regexp -nocase {^([^:]+):(.+)$} $line x key value] { + lappend state(meta) $key $value + } elseif {[regexp ^HTTP $line]} { + set state(http) $line + } + } + } else { + if [catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) {$s $token}] + } else { + set block [read $s $state(-blocksize)] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + } + } + if {$n >= 0} { + incr state(currentsize) $n + } + } err] { + Finish $token $err + } else { + if [info exists state(-progress)] { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + } + } +} + proc http::CopyStart {s token} { + variable $token + upvar 0 $token state + if [catch { + fcopy $s $state(-channel) -size $state(-blocksize) -command \ + [list http::CopyDone $token] + } err] { + Finish $token $err + } +} + proc http::CopyDone {token count {error {}}} { + variable $token + upvar 0 $token state + set s $state(sock) + incr state(currentsize) $count + if [info exists state(-progress)] { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + if {([string length $error] != 0)} { + Finish $token $error + } elseif {[::eof $s]} { + Eof $token + } else { + CopyStart $s $token + } +} + proc http::Eof {token} { + variable $token + upvar 0 $token state + if {$state(state) == "header"} { + # Premature eof + set state(status) eof + } else { + set state(status) ok + } + set state(state) eof + Finish $token +} + +# http::wait -- +# +# See documentaion for details. +# +# Arguments: +# token Connection token. +# Results: +# The status after the wait. + +proc http::wait {token} { + variable $token + upvar 0 $token state + + if {![info exists state(status)] || [string length $state(status)] == 0} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + return $state(status) +} + +# http::formatQuery -- +# +# See documentaion for details. +# Call http::formatQuery with an even number of arguments, where +# the first is a name, the second is a value, the third is another +# name, and so on. +# +# Arguments: +# args A list of name-value pairs. +# Results: +# TODO + +proc http::formatQuery {args} { + set result "" + set sep "" + foreach i $args { + append result $sep [mapReply $i] + if {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# The spec says: "non-alphanumeric characters are replaced by '%HH'" +# 1 leave alphanumerics characters alone +# 2 Convert every other character to an array lookup +# 3 Escape constructs that are "special" to the tcl parser +# 4 "subst" the result, doing all the array substitutions + + proc http::mapReply {string} { + variable formMap + set alphanumeric a-zA-Z0-9 + regsub -all \[^$alphanumeric\] $string {$formMap(&)} string + regsub -all \n $string {\\n} string + regsub -all \t $string {\\t} string + regsub -all {[][{})\\]\)} $string {\\&} string + return [subst $string] +} + +# Default proxy filter. + proc http::ProxyRequired {host} { + variable http + if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { + if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { + set http(-proxyport) 8080 + } + return [list $http(-proxyhost) $http(-proxyport)] + } else { + return {} + } +} --- electric-6.05.orig/lib/tcl/init.tcl +++ electric-6.05/lib/tcl/init.tcl @@ -0,0 +1,785 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +if {[info commands package] == ""} { + error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" +} +package require -exact Tcl 8.0 + +# Compute the auto path to use in this interpreter. +# (auto_path could be already set, in safe interps for instance) + +if {![info exists auto_path]} { + if [catch {set auto_path $env(TCLLIBPATH)}] { + set auto_path "" + } +} +if {[lsearch -exact $auto_path [info library]] < 0} { + lappend auto_path [info library] +} +catch { + foreach __dir $tcl_pkgPath { + if {[lsearch -exact $auto_path $__dir] < 0} { + lappend auto_path $__dir + } + } + unset __dir +} + +# Setup the unknown package handler + +package unknown tclPkgUnknown + +# Conditionalize for presence of exec. + +if {[info commands exec] == ""} { + + # Some machines, such as the Macintosh, do not have exec. Also, on all + # platforms, safe interpreters do not have exec. + + set auto_noexec 1 +} +set errorCode "" +set errorInfo "" + +# Define a log command (which can be overwitten to log errors +# differently, specially when stderr is not available) + +if {[info commands tclLog] == ""} { + proc tclLog {string} { + catch {puts stderr $string} + } +} + +# The procs defined in this file that have a leading space +# are 'hidden' from auto_mkindex because they are not +# auto-loadable. + + +# unknown -- +# This procedure is called when a Tcl command is invoked that doesn't +# exist in the interpreter. It takes the following steps to make the +# command available: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + + proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel 1 $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + + if {([info level] == 1) && ([info script] == "") \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set redir "" + if {[info commands console] == ""} { + set redir ">&@stdout <@stdin" + } + return [uplevel exec $redir $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {$name == "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name dummy event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if [info exists newcmd] { + tclLog $newcmd + history change $newcmd 0 + return [uplevel $newcmd] + } + + set ret [catch {set cmds [info commands $name*]} msg] + if {[string compare $name "::"] == 0} { + set name "" + } + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" + } + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds] != 0} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + +# auto_load -- +# Checks a collection of library directories to see if a procedure +# is defined in one of them. If so, it sources the appropriate +# library file to create the procedure. Returns 1 if it successfully +# loaded the procedure, 0 otherwise. +# +# Arguments: +# cmd - Name of the command to find and load. +# namespace (optional) The namespace where the command is being used - must be +# a canonical namespace as returned [namespace current] +# for instance. If not given, namespace current is used. + + proc auto_load {cmd {namespace {}}} { + global auto_index auto_oldpath auto_path env errorInfo errorCode + + if {[string length $namespace] == 0} { + set namespace [uplevel {namespace current}] + } + set nameList [auto_qualify $cmd $namespace] + # workaround non canonical auto_index entries that might be around + # from older auto_mkindex versions + lappend nameList $cmd + foreach name $nameList { + if [info exists auto_index($name)] { + uplevel #0 $auto_index($name) + return [expr {[info commands $name] != ""}] + } + } + if ![info exists auto_path] { + return 0 + } + if [info exists auto_oldpath] { + if {$auto_oldpath == $auto_path} { + return 0 + } + } + set auto_oldpath $auto_path + + # Check if we are a safe interpreter. In that case, we support only + # newer format tclIndex files. + + set issafe [interp issafe] + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set f "" + if {$issafe} { + catch {source [file join $dir tclIndex]} + } elseif [catch {set f [open [file join $dir tclIndex]]}] { + continue + } else { + set error [catch { + set id [gets $f] + if {$id == "# Tcl autoload index file, version 2.0"} { + eval [read $f] + } elseif {$id == \ + "# Tcl autoload index file: each line identifies a Tcl"} { + while {[gets $f line] >= 0} { + if {([string index $line 0] == "#") + || ([llength $line] != 2)} { + continue + } + set name [lindex $line 0] + set auto_index($name) \ + "source [file join $dir [lindex $line 1]]" + } + } else { + error \ + "[file join $dir tclIndex] isn't a proper Tcl index file" + } + } msg] + if {$f != ""} { + close $f + } + if $error { + error $msg $errorInfo $errorCode + } + } + } + foreach name $nameList { + if [info exists auto_index($name)] { + uplevel #0 $auto_index($name) + if {[info commands $name] != ""} { + return 1 + } + } + } + return 0 +} + +# auto_qualify -- +# compute a fully qualified names list for use in the auto_index array. +# For historical reasons, commands in the global namespace do not have leading +# :: in the index key. The list has two elements when the command name is +# relative (no leading ::) and the namespace is not the global one. Otherwise +# only one name is returned (and searched in the auto_index). +# +# Arguments - +# cmd The command name. Can be any name accepted for command +# invocations (Like "foo::::bar"). +# namespace The namespace where the command is being used - must be +# a canonical namespace as returned by [namespace current] +# for instance. + + proc auto_qualify {cmd namespace} { + + # count separators and clean them up + # (making sure that foo:::::bar will be treated as foo::bar) + set n [regsub -all {::+} $cmd :: cmd] + + # Ignore namespace if the name starts with :: + # Handle special case of only leading :: + + # Before each return case we give an example of which category it is + # with the following form : + # ( inputCmd, inputNameSpace) -> output + + if {[regexp {^::(.*)$} $cmd x tail]} { + if {$n > 1} { + # ( ::foo::bar , * ) -> ::foo::bar + return [list $cmd] + } else { + # ( ::global , * ) -> global + return [list $tail] + } + } + + # Potentially returning 2 elements to try : + # (if the current namespace is not the global one) + + if {$n == 0} { + if {[string compare $namespace ::] == 0} { + # ( nocolons , :: ) -> nocolons + return [list $cmd] + } else { + # ( nocolons , ::sub ) -> ::sub::nocolons nocolons + return [list ${namespace}::$cmd $cmd] + } + } else { + if {[string compare $namespace ::] == 0} { + # ( foo::bar , :: ) -> ::foo::bar + return [list ::$cmd] + } else { + # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar + return [list ${namespace}::$cmd ::$cmd] + } + } +} + +if {[string compare $tcl_platform(platform) windows] == 0} { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to a shell builtin or an executable in the +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Windows version. +# +# Note that info executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + + if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename + ren rmdir rd time type ver vol} $name] != -1} { + return [set auto_execs($name) [list $env(COMSPEC) /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext {{} .com .exe .bat} { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + if {$tcl_platform(os) == "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + if {[info exists env(PATH)]} { + append path $env(PATH) + } + + foreach dir [split $path {;}] { + if {$dir == ""} { + set dir . + } + foreach ext {{} .com .exe .bat} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + return "" +} + +} else { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to an executable in the path. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) [list $name] + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir == ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) [list $file] + return $auto_execs($name) + } + } + return "" +} + +} +# auto_reset -- +# Destroy all cached information for auto-loading and auto-execution, +# so that the information gets recomputed the next time it's needed. +# Also delete any procedures that are listed in the auto-load index +# except those defined in this file. +# +# Arguments: +# None. + +proc auto_reset {} { + global auto_execs auto_index auto_oldpath + foreach p [info procs] { + if {[info exists auto_index($p)] && ![string match auto_* $p] + && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup + tclMacPkgSearch tclPkgUnknown} $p] < 0)} { + rename $p {} + } + } + catch {unset auto_execs} + catch {unset auto_index} + catch {unset auto_oldpath} +} + +# auto_mkindex -- +# Regenerate a tclIndex file from Tcl source files. Takes as argument +# the name of the directory in which the tclIndex file is to be placed, +# followed by any number of glob patterns to use in that directory to +# locate all of the relevant files. It does not parse or source the file +# so the generated index will not contain the appropriate namespace qualifiers +# if you don't explicitly specify it. +# +# Arguments: +# dir - Name of the directory in which to create an index. +# args - Any number of additional arguments giving the +# names of files within dir. If no additional +# are given auto_mkindex will look for *.tcl. + +proc auto_mkindex {dir args} { + global errorCode errorInfo + set oldDir [pwd] + cd $dir + set dir [pwd] + append index "# Tcl autoload index file, version 2.0\n" + append index "# This file is generated by the \"auto_mkindex\" command\n" + append index "# and sourced to set up indexing information for one or\n" + append index "# more commands. Typically each line is a command that\n" + append index "# sets an element in the auto_index array, where the\n" + append index "# element name is the name of a command and the value is\n" + append index "# a script that loads the command.\n\n" + if {$args == ""} { + set args *.tcl + } + foreach file [eval glob $args] { + set f "" + set error [catch { + set f [open $file] + while {[gets $f line] >= 0} { + if [regexp {^proc[ ]+([^ ]*)} $line match procName] { + set procName [lindex [auto_qualify $procName "::"] 0] + append index "set [list auto_index($procName)]" + append index " \[list source \[file join \$dir [list $file]\]\]\n" + } + } + close $f + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } + } + set f "" + set error [catch { + set f [open tclIndex w] + puts $f $index nonewline + close $f + cd $oldDir + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } +} + +# pkg_mkIndex -- +# This procedure creates a package index in a given directory. The +# package index consists of a "pkgIndex.tcl" file whose contents are +# a Tcl script that sets up package information with "package require" +# commands. The commands describe all of the packages defined by the +# files given as arguments. +# +# Arguments: +# dir - Name of the directory in which to create the index. +# args - Any number of additional arguments, each giving +# a glob pattern that matches the names of one or +# more shared libraries or Tcl script files in +# dir. + +proc pkg_mkIndex {dir args} { + global errorCode errorInfo + if {[llength $args] == 0} { + return -code error "wrong # args: should be\ + \"pkg_mkIndex dir pattern ?pattern ...?\""; + } + append index "# Tcl package index file, version 1.0\n" + append index "# This file is generated by the \"pkg_mkIndex\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + set oldDir [pwd] + cd $dir + foreach file [eval glob $args] { + # For each file, figure out what commands and packages it provides. + # To do this, create a child interpreter, load the file into the + # interpreter, and get a list of the new commands and packages + # that are defined. Define an empty "package unknown" script so + # that there are no recursive package inclusions. + + set c [interp create] + + # If Tk is loaded in the parent interpreter, load it into the + # child also, in case the extension depends on it. + + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + $c eval {set argv {-geometry +0+0}} + load [lindex $pkg 0] Tk $c + break + } + } + $c eval [list set file $file] + if [catch { + $c eval { + proc dummy args {} + rename package package-orig + proc package {what args} { + switch -- $what { + require { return ; # ignore transitive requires } + default { eval package-orig {$what} $args } + } + } + proc pkgGetAllNamespaces {{root {}}} { + set list $root + foreach ns [namespace children $root] { + eval lappend list [pkgGetAllNamespaces $ns] + } + return $list + } + package unknown dummy + set origCmds [info commands] + set dir "" ;# in case file is pkgIndex.tcl + set pkgs "" + + # Try to load the file if it has the shared library extension, + # otherwise source it. It's important not to try to load + # files that aren't shared libraries, because on some systems + # (like SunOS) the loader will abort the whole application + # when it gets an error. + + if {[string compare [file extension $file] \ + [info sharedlibextension]] == 0} { + + # The "file join ." command below is necessary. Without + # it, if the file name has no \'s and we're on UNIX, the + # load command will invoke the LD_LIBRARY_PATH search + # mechanism, which could cause the wrong file to be used. + + load [file join . $file] + set type load + } else { + source $file + set type source + } + foreach ns [pkgGetAllNamespaces] { + namespace import ${ns}::* + } + foreach i [info commands] { + set cmds($i) 1 + } + foreach i $origCmds { + catch {unset cmds($i)} + + } + foreach i [array names cmds] { + # reverse engineer which namespace a command comes from + set absolute [namespace origin $i] + if {[string compare ::$i $absolute] != 0} { + set cmds($absolute) 1 + unset cmds($i) + } + } + foreach i [package names] { + if {([string compare [package provide $i] ""] != 0) + && ([string compare $i Tcl] != 0) + && ([string compare $i Tk] != 0)} { + lappend pkgs [list $i [package provide $i]] + } + } + } + } msg] { + tclLog "error while loading or sourcing $file: $msg" + } + foreach pkg [$c eval set pkgs] { + lappend files($pkg) [list $file [$c eval set type] \ + [lsort [$c eval array names cmds]]] + } + interp delete $c + } + foreach pkg [lsort [array names files]] { + append index "\npackage ifneeded $pkg\ + \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ + [list $files($pkg)]\]" + } + set f [open pkgIndex.tcl w] + puts $f $index + close $f + cd $oldDir +} + +# tclPkgSetup -- +# This is a utility procedure use by pkgIndex.tcl files. It is invoked +# as part of a "package ifneeded" script. It calls "package provide" +# to indicate that a package is available, then sets entries in the +# auto_index array so that the package's files will be auto-loaded when +# the commands are used. +# +# Arguments: +# dir - Directory containing all the files for this package. +# pkg - Name of the package (no version number). +# version - Version number for the package, such as 2.1.3. +# files - List of files that constitute the package. Each +# element is a sub-list with three elements. The first +# is the name of a file relative to $dir, the second is +# "load" or "source", indicating whether the file is a +# loadable binary or a script to source, and the third +# is a list of commands defined by this file. + +proc tclPkgSetup {dir pkg version files} { + global auto_index + + package provide $pkg $version + foreach fileInfo $files { + set f [lindex $fileInfo 0] + set type [lindex $fileInfo 1] + foreach cmd [lindex $fileInfo 2] { + if {$type == "load"} { + set auto_index($cmd) [list load [file join $dir $f] $pkg] + } else { + set auto_index($cmd) [list source [file join $dir $f]] + } + } + } +} + +# tclMacPkgSearch -- +# The procedure is used on the Macintosh to search a given directory for files +# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the +# interpreter to setup the package database. + +proc tclMacPkgSearch {dir} { + foreach x [glob -nocomplain [file join $dir *.shlb]] { + if [file isfile $x] { + set res [resource open $x] + foreach y [resource list TEXT $res] { + if {$y == "pkgIndex"} {source -rsrc pkgIndex} + } + catch {resource close $res} + } + } +} + +# tclPkgUnknown -- +# This procedure provides the default for the "package unknown" function. +# It is invoked when a package that's needed can't be found. It scans +# the auto_path directories and their immediate children looking for +# pkgIndex.tcl files and sources any such files that are found to setup +# the package database. (On the Macintosh we also search for pkgIndex +# TEXT resources in all files.) +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tclPkgUnknown {name version {exact {}}} { + global auto_path tcl_platform env + + if ![info exists auto_path] { + return + } + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + # we can't use glob in safe interps, so enclose the following + # in a catch statement + catch { + foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ + * pkgIndex.tcl]] { + set dir [file dirname $file] + if [catch {source $file} msg] { + tclLog "error reading package index file $file: $msg" + } + } + } + set dir [lindex $auto_path $i] + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file readable", nor stderr channel + if {[interp issafe] || [file readable $file]} { + if {[catch {source $file} msg] && ![interp issafe]} { + tclLog "error reading package index file $file: $msg" + } + } + # On the Macintosh we also look in the resource fork + # of shared libraries + # We can't use tclMacPkgSearch in safe interps because it uses glob + if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} { + set dir [lindex $auto_path $i] + tclMacPkgSearch $dir + foreach x [glob -nocomplain [file join $dir *]] { + if [file isdirectory $x] { + set dir $x + tclMacPkgSearch $dir + } + } + } + } +} --- electric-6.05.orig/lib/tcl/tclIndex +++ electric-6.05/lib/tcl/tclIndex @@ -0,0 +1,30 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(auto_execok) [list source [file join $dir init.tcl]] +set auto_index(auto_reset) [list source [file join $dir init.tcl]] +set auto_index(auto_mkindex) [list source [file join $dir init.tcl]] +set auto_index(pkg_mkIndex) [list source [file join $dir init.tcl]] +set auto_index(tclPkgSetup) [list source [file join $dir init.tcl]] +set auto_index(tclMacPkgSearch) [list source [file join $dir init.tcl]] +set auto_index(tclPkgUnknown) [list source [file join $dir init.tcl]] +set auto_index(parray) [list source [file join $dir parray.tcl]] +set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]] +set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] +set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] +set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] +set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]] +set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]] +set auto_index(history) [list source [file join $dir history.tcl]] --- electric-6.05.orig/lib/tcl/parray.tcl +++ electric-6.05/lib/tcl/parray.tcl @@ -0,0 +1,29 @@ +# parray: +# Print the contents of a global array on stdout. +# +# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44 +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc parray {a {pattern *}} { + upvar 1 $a array + if ![array exists array] { + error "\"$a\" isn't an array" + } + set maxl 0 + foreach name [lsort [array names array $pattern]] { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name [lsort [array names array $pattern]] { + set nameString [format %s(%s) $a $name] + puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] + } +} --- electric-6.05.orig/lib/tcl/safe.tcl +++ electric-6.05/lib/tcl/safe.tcl @@ -0,0 +1,893 @@ +# safe.tcl -- +# +# This file provide a safe loading/sourcing mechanism for safe interpreters. +# It implements a virtual path mecanism to hide the real pathnames from the +# slave. It runs in a master interpreter and sets up data structure and +# aliases that will be invoked when used from a slave interpreter. +# +# See the safe.n man page for details. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20 + +# +# The implementation is based on namespaces. These naming conventions +# are followed: +# Private procs starts with uppercase. +# Public procs are exported and starts with lowercase +# + +# Needed utilities package +package require opt 0.2; + +# Create the safe namespace +namespace eval ::safe { + + # Exported API: + namespace export interpCreate interpInit interpConfigure interpDelete \ + interpAddToAccessPath interpFindInAccessPath \ + setLogCmd ; + +# Proto/dummy declarations for auto_mkIndex +proc ::safe::interpCreate {} {} +proc ::safe::interpInit {} {} +proc ::safe::interpConfigure {} {} + + + #### + # + # Setup the arguments parsing + # + #### + + # Share the descriptions + set temp [::tcl::OptKeyRegister { + {-accessPath -list {} "access path for the slave"} + {-noStatics "prevent loading of statically linked pkgs"} + {-statics true "loading of statically linked pkgs"} + {-nestedLoadOk "allow nested loading"} + {-nested false "nested loading"} + {-deleteHook -script {} "delete hook"} + }] + + # create case (slave is optional) + ::tcl::OptKeyRegister { + {?slave? -name {} "name of the slave (optional)"} + } ::safe::interpCreate ; + # adding the flags sub programs to the command program + # (relying on Opt's internal implementation details) + lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp); + + # init and configure (slave is needed) + ::tcl::OptKeyRegister { + {slave -name {} "name of the slave"} + } ::safe::interpIC; + # adding the flags sub programs to the command program + # (relying on Opt's internal implementation details) + lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp); + # temp not needed anymore + ::tcl::OptKeyDelete $temp; + + + # Helper function to resolve the dual way of specifying staticsok + # (either by -noStatics or -statics 0) + proc InterpStatics {} { + foreach v {Args statics noStatics} { + upvar $v $v + } + set flag [::tcl::OptProcArgGiven -noStatics]; + if {$flag && ($noStatics == $statics) + && ([::tcl::OptProcArgGiven -statics])} { + return -code error\ + "conflicting values given for -statics and -noStatics"; + } + if {$flag} { + return [expr {!$noStatics}]; + } else { + return $statics + } + } + + # Helper function to resolve the dual way of specifying nested loading + # (either by -nestedLoadOk or -nested 1) + proc InterpNested {} { + foreach v {Args nested nestedLoadOk} { + upvar $v $v + } + set flag [::tcl::OptProcArgGiven -nestedLoadOk]; + # note that the test here is the opposite of the "InterpStatics" + # one (it is not -noNested... because of the wanted default value) + if {$flag && ($nestedLoadOk != $nested) + && ([::tcl::OptProcArgGiven -nested])} { + return -code error\ + "conflicting values given for -nested and -nestedLoadOk"; + } + if {$flag} { + # another difference with "InterpStatics" + return $nestedLoadOk + } else { + return $nested + } + } + + #### + # + # API entry points that needs argument parsing : + # + #### + + + # Interface/entry point function and front end for "Create" + proc interpCreate {args} { + set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + InterpCreate $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook; + } + + proc interpInit {args} { + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + if {![::interp exists $slave]} { + return -code error \ + "\"$slave\" is not an interpreter"; + } + InterpInit $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook; + } + + proc CheckInterp {slave} { + if {![IsInterp $slave]} { + return -code error \ + "\"$slave\" is not an interpreter managed by ::safe::" ; + } + } + + # Interface/entry point function and front end for "Configure" + # This code is awfully pedestrian because it would need + # more coupling and support between the way we store the + # configuration values in safe::interp's and the Opt package + # Obviously we would like an OptConfigure + # to avoid duplicating all this code everywhere. -> TODO + # (the app should share or access easily the program/value + # stored by opt) + # This is even more complicated by the boolean flags with no values + # that we had the bad idea to support for the sake of user simplicity + # in create/init but which makes life hard in configure... + # So this will be hopefully written and some integrated with opt1.0 + # (hopefully for tcl8.1 ?) + proc interpConfigure {args} { + switch [llength $args] { + 1 { + # If we have exactly 1 argument + # the semantic is to return all the current configuration + # We still call OptKeyParse though we know that "slave" + # is our given argument because it also checks + # for the "-help" option. + set Args [::tcl::OptKeyParse ::safe::interpIC $args]; + CheckInterp $slave; + set res {} + lappend res [list -accessPath [Set [PathListName $slave]]] + lappend res [list -statics [Set [StaticsOkName $slave]]] + lappend res [list -nested [Set [NestedOkName $slave]]] + lappend res [list -deleteHook [Set [DeleteHookName $slave]]] + join $res + } + 2 { + # If we have exactly 2 arguments + # the semantic is a "configure get" + ::tcl::Lassign $args slave arg; + # get the flag sub program (we 'know' about Opt's internal + # representation of data) + set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2] + set hits [::tcl::OptHits desc $arg]; + if {$hits > 1} { + return -code error [::tcl::OptAmbigous $desc $arg] + } elseif {$hits == 0} { + return -code error [::tcl::OptFlagUsage $desc $arg] + } + CheckInterp $slave; + set item [::tcl::OptCurDesc $desc]; + set name [::tcl::OptName $item]; + switch -exact -- $name { + -accessPath { + return [list -accessPath [Set [PathListName $slave]]] + } + -statics { + return [list -statics [Set [StaticsOkName $slave]]] + } + -nested { + return [list -nested [Set [NestedOkName $slave]]] + } + -deleteHook { + return [list -deleteHook [Set [DeleteHookName $slave]]] + } + -noStatics { + # it is most probably a set in fact + # but we would need then to jump to the set part + # and it is not *sure* that it is a set action + # that the user want, so force it to use the + # unambigous -statics ?value? instead: + return -code error\ + "ambigous query (get or set -noStatics ?)\ + use -statics instead"; + } + -nestedLoadOk { + return -code error\ + "ambigous query (get or set -nestedLoadOk ?)\ + use -nested instead"; + } + default { + return -code error "unknown flag $name (bug)"; + } + } + } + default { + # Otherwise we want to parse the arguments like init and create + # did + set Args [::tcl::OptKeyParse ::safe::interpIC $args]; + CheckInterp $slave; + # Get the current (and not the default) values of + # whatever has not been given: + if {![::tcl::OptProcArgGiven -accessPath]} { + set doreset 1 + set accessPath [Set [PathListName $slave]] + } else { + set doreset 0 + } + if { (![::tcl::OptProcArgGiven -statics]) + && (![::tcl::OptProcArgGiven -noStatics]) } { + set statics [Set [StaticsOkName $slave]] + } else { + set statics [InterpStatics] + } + if { ([::tcl::OptProcArgGiven -nested]) + || ([::tcl::OptProcArgGiven -nestedLoadOk]) } { + set nested [InterpNested] + } else { + set nested [Set [NestedOkName $slave]] + } + if {![::tcl::OptProcArgGiven -deleteHook]} { + set deleteHook [Set [DeleteHookName $slave]] + } + # we can now reconfigure : + InterpSetConfig $slave $accessPath \ + $statics $nested $deleteHook; + # auto_reset the slave (to completly synch the new access_path) + if {$doreset} { + if {[catch {::interp eval $slave {auto_reset}} msg]} { + Log $slave "auto_reset failed: $msg"; + } else { + Log $slave "successful auto_reset" NOTICE; + } + } + } + } + } + + + #### + # + # Functions that actually implements the exported APIs + # + #### + + + # + # safe::InterpCreate : doing the real job + # + # This procedure creates a safe slave and initializes it with the + # safe base aliases. + # NB: slave name must be simple alphanumeric string, no spaces, + # no (), no {},... {because the state array is stored as part of the name} + # + # Returns the slave name. + # + # Optional Arguments : + # + slave name : if empty, generated name will be used + # + access_path: path list controlling where load/source can occur, + # if empty: the master auto_path will be used. + # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) + # if 1 :static packages are ok. + # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) + # if 1 : multiple levels are ok. + + # use the full name and no indent so auto_mkIndex can find us + proc ::safe::InterpCreate { + slave + access_path + staticsok + nestedok + deletehook + } { + # Create the slave. + if {[string compare "" $slave]} { + ::interp create -safe $slave; + } else { + # empty argument: generate slave name + set slave [::interp create -safe]; + } + Log $slave "Created" NOTICE; + + # Initialize it. (returns slave name) + InterpInit $slave $access_path $staticsok $nestedok $deletehook; + } + + + # + # InterpSetConfig (was setAccessPath) : + # Sets up slave virtual auto_path and corresponding structure + # within the master. Also sets the tcl_library in the slave + # to be the first directory in the path. + # Nb: If you change the path after the slave has been initialized + # you probably need to call "auto_reset" in the slave in order that it + # gets the right auto_index() array values. + + proc ::safe::InterpSetConfig {slave access_path staticsok\ + nestedok deletehook} { + + # determine and store the access path if empty + if {[string match "" $access_path]} { + set access_path [uplevel #0 set auto_path]; + # Make sure that tcl_library is in auto_path + # and at the first position (needed by setAccessPath) + set where [lsearch -exact $access_path [info library]]; + if {$where == -1} { + # not found, add it. + set access_path [concat [list [info library]] $access_path]; + Log $slave "tcl_library was not in auto_path,\ + added it to slave's access_path" NOTICE; + } elseif {$where != 0} { + # not first, move it first + set access_path [concat [list [info library]]\ + [lreplace $access_path $where $where]]; + Log $slave "tcl_libray was not in first in auto_path,\ + moved it to front of slave's access_path" NOTICE; + + } + + # Add 1st level sub dirs (will searched by auto loading from tcl + # code in the slave using glob and thus fail, so we add them + # here so by default it works the same). + set access_path [AddSubDirs $access_path]; + } + + Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + nestedok=$nestedok deletehook=($deletehook)" NOTICE; + + # clear old autopath if it existed + set nname [PathNumberName $slave]; + if {[Exists $nname]} { + set n [Set $nname]; + for {set i 0} {$i<$n} {incr i} { + Unset [PathToken $i $slave]; + } + } + + # build new one + set slave_auto_path {} + set i 0; + foreach dir $access_path { + Set [PathToken $i $slave] $dir; + lappend slave_auto_path "\$[PathToken $i]"; + incr i; + } + Set $nname $i; + Set [PathListName $slave] $access_path; + Set [VirtualPathListName $slave] $slave_auto_path; + + Set [StaticsOkName $slave] $staticsok + Set [NestedOkName $slave] $nestedok + Set [DeleteHookName $slave] $deletehook + + SyncAccessPath $slave; + } + + # + # + # FindInAccessPath: + # Search for a real directory and returns its virtual Id + # (including the "$") +proc ::safe::interpFindInAccessPath {slave path} { + set access_path [GetAccessPath $slave]; + set where [lsearch -exact $access_path $path]; + if {$where == -1} { + return -code error "$path not found in access path $access_path"; + } + return "\$[PathToken $where]"; + } + + # + # addToAccessPath: + # add (if needed) a real directory to access path + # and return its virtual token (including the "$"). +proc ::safe::interpAddToAccessPath {slave path} { + # first check if the directory is already in there + if {![catch {interpFindInAccessPath $slave $path} res]} { + return $res; + } + # new one, add it: + set nname [PathNumberName $slave]; + set n [Set $nname]; + Set [PathToken $n $slave] $path; + + set token "\$[PathToken $n]"; + + Lappend [VirtualPathListName $slave] $token; + Lappend [PathListName $slave] $path; + Set $nname [expr $n+1]; + + SyncAccessPath $slave; + + return $token; + } + + # This procedure applies the initializations to an already existing + # interpreter. It is useful when you want to install the safe base + # aliases into a preexisting safe interpreter. + proc ::safe::InterpInit { + slave + access_path + staticsok + nestedok + deletehook + } { + + # Configure will generate an access_path when access_path is + # empty. + InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook; + + # These aliases let the slave load files to define new commands + + # NB we need to add [namespace current], aliases are always + # absolute paths. + ::interp alias $slave source {} [namespace current]::AliasSource $slave + ::interp alias $slave load {} [namespace current]::AliasLoad $slave + + # This alias lets the slave have access to a subset of the 'file' + # command functionality. + + AliasSubset $slave file file dir.* join root.* ext.* tail \ + path.* split + + # This alias interposes on the 'exit' command and cleanly terminates + # the slave. + + ::interp alias $slave exit {} [namespace current]::interpDelete $slave + + # The allowed slave variables already have been set + # by Tcl_MakeSafe(3) + + + # Source init.tcl into the slave, to get auto_load and other + # procedures defined: + + # We don't try to use the -rsrc on the mac because it would get + # confusing if you would want to customize init.tcl + # for a given set of safe slaves, on all the platforms + # you just need to give a specific access_path and + # the mac should be no exception. As there is no + # obvious full "safe ressources" design nor implementation + # for the mac, safe interps there will just don't + # have that ability. (A specific app can still reenable + # that using custom aliases if they want to). + # It would also make the security analysis and the Safe Tcl security + # model platform dependant and thus more error prone. + + if {[catch {::interp eval $slave\ + {source [file join $tcl_library init.tcl]}}\ + msg]} { + Log $slave "can't source init.tcl ($msg)"; + error "can't source init.tcl into slave $slave ($msg)" + } + + return $slave + } + + + # Add (only if needed, avoid duplicates) 1 level of + # sub directories to an existing path list. + # Also removes non directories from the returned list. + proc AddSubDirs {pathList} { + set res {} + foreach dir $pathList { + if {[file isdirectory $dir]} { + # check that we don't have it yet as a children + # of a previous dir + if {[lsearch -exact $res $dir]<0} { + lappend res $dir; + } + foreach sub [glob -nocomplain -- [file join $dir *]] { + if { ([file isdirectory $sub]) + && ([lsearch -exact $res $sub]<0) } { + # new sub dir, add it ! + lappend res $sub; + } + } + } + } + return $res; + } + + # This procedure deletes a safe slave managed by Safe Tcl and + # cleans up associated state: + +proc ::safe::interpDelete {slave} { + + Log $slave "About to delete" NOTICE; + + # If the slave has a cleanup hook registered, call it. + # check the existance because we might be called to delete an interp + # which has not been registered with us at all + set hookname [DeleteHookName $slave]; + if {[Exists $hookname]} { + set hook [Set $hookname]; + if {![::tcl::Lempty $hook]} { + # remove the hook now, otherwise if the hook + # calls us somehow, we'll loop + Unset $hookname; + if {[catch {eval $hook $slave} err]} { + Log $slave "Delete hook error ($err)"; + } + } + } + + # Discard the global array of state associated with the slave, and + # delete the interpreter. + + set statename [InterpStateName $slave]; + if {[Exists $statename]} { + Unset $statename; + } + + # if we have been called twice, the interp might have been deleted + # already + if {[::interp exists $slave]} { + ::interp delete $slave; + Log $slave "Deleted" NOTICE; + } + + return + } + + # Set (or get) the loging mecanism + +proc ::safe::setLogCmd {args} { + variable Log; + if {[llength $args] == 0} { + return $Log; + } else { + if {[llength $args] == 1} { + set Log [lindex $args 0]; + } else { + set Log $args + } + } +} + + # internal variable + variable Log {} + + # ------------------- END OF PUBLIC METHODS ------------ + + + # + # sets the slave auto_path to the master recorded value. + # also sets tcl_library to the first token of the virtual path. + # + proc SyncAccessPath {slave} { + set slave_auto_path [Set [VirtualPathListName $slave]]; + ::interp eval $slave [list set auto_path $slave_auto_path]; + Log $slave \ + "auto_path in $slave has been set to $slave_auto_path"\ + NOTICE; + ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]; + } + + # base name for storing all the slave states + # the array variable name for slave foo is thus "Sfoo" + # and for sub slave {foo bar} "Sfoo bar" (spaces are handled + # ok everywhere (or should)) + # We add the S prefix to avoid that a slave interp called "Log" + # would smash our "Log" variable. + proc InterpStateName {slave} { + return "S$slave"; + } + + # Check that the given slave is "one of us" + proc IsInterp {slave} { + expr { ([Exists [InterpStateName $slave]]) + && ([::interp exists $slave])} + } + + # returns the virtual token for directory number N + # if the slave argument is given, + # it will return the corresponding master global variable name + proc PathToken {n {slave ""}} { + if {[string compare "" $slave]} { + return "[InterpStateName $slave](access_path,$n)"; + } else { + # We need to have a ":" in the token string so + # [file join] on the mac won't turn it into a relative + # path. + return "p(:$n:)"; + } + } + # returns the variable name of the complete path list + proc PathListName {slave} { + return "[InterpStateName $slave](access_path)"; + } + # returns the variable name of the complete path list + proc VirtualPathListName {slave} { + return "[InterpStateName $slave](access_path_slave)"; + } + # returns the variable name of the number of items + proc PathNumberName {slave} { + return "[InterpStateName $slave](access_path,n)"; + } + # returns the staticsok flag var name + proc StaticsOkName {slave} { + return "[InterpStateName $slave](staticsok)"; + } + # returns the nestedok flag var name + proc NestedOkName {slave} { + return "[InterpStateName $slave](nestedok)"; + } + # Run some code at the namespace toplevel + proc Toplevel {args} { + namespace eval [namespace current] $args; + } + # set/get values + proc Set {args} { + eval Toplevel set $args; + } + # lappend on toplevel vars + proc Lappend {args} { + eval Toplevel lappend $args; + } + # unset a var/token (currently just an global level eval) + proc Unset {args} { + eval Toplevel unset $args; + } + # test existance + proc Exists {varname} { + Toplevel info exists $varname; + } + # short cut for access path getting + proc GetAccessPath {slave} { + Set [PathListName $slave] + } + # short cut for statics ok flag getting + proc StaticsOk {slave} { + Set [StaticsOkName $slave] + } + # short cut for getting the multiples interps sub loading ok flag + proc NestedOk {slave} { + Set [NestedOkName $slave] + } + # interp deletion storing hook name + proc DeleteHookName {slave} { + return [InterpStateName $slave](cleanupHook) + } + + # + # translate virtual path into real path + # + proc TranslatePath {slave path} { + # somehow strip the namespaces 'functionality' out (the danger + # is that we would strip valid macintosh "../" queries... : + if {[regexp {(::)|(\.\.)} $path]} { + error "invalid characters in path $path"; + } + set n [expr [Set [PathNumberName $slave]]-1]; + for {} {$n>=0} {incr n -1} { + # fill the token virtual names with their real value + set [PathToken $n] [Set [PathToken $n $slave]]; + } + # replaces the token by their value + subst -nobackslashes -nocommands $path; + } + + + # Log eventually log an error + # to enable error logging, set Log to {puts stderr} for instance + proc Log {slave msg {type ERROR}} { + variable Log; + if {[info exists Log] && [llength $Log]} { + eval $Log [list "$type for slave $slave : $msg"]; + } + } + + + # file name control (limit access to files/ressources that should be + # a valid tcl source file) + proc CheckFileName {slave file} { + # limit what can be sourced to .tcl + # and forbid files with more than 1 dot and + # longer than 14 chars + set ftail [file tail $file]; + if {[string length $ftail]>14} { + error "$ftail: filename too long"; + } + if {[regexp {\..*\.} $ftail]} { + error "$ftail: more than one dot is forbidden"; + } + if {[string compare $ftail "tclIndex"] && \ + [string compare [string tolower [file extension $ftail]]\ + ".tcl"]} { + error "$ftail: must be a *.tcl or tclIndex"; + } + + if {![file exists $file]} { + # don't tell the file path + error "no such file or directory"; + } + + if {![file readable $file]} { + # don't tell the file path + error "not readable"; + } + + } + + + # AliasSource is the target of the "source" alias in safe interpreters. + + proc AliasSource {slave args} { + + set argc [llength $args]; + # Allow only "source filename" + # (and not mac specific -rsrc for instance - see comment in ::init + # for current rationale) + if {$argc != 1} { + set msg "wrong # args: should be \"source fileName\"" + Log $slave "$msg ($args)"; + return -code error $msg; + } + set file [lindex $args 0] + + # get the real path from the virtual one. + if {[catch {set file [TranslatePath $slave $file]} msg]} { + Log $slave $msg; + return -code error "permission denied" + } + + # check that the path is in the access path of that slave + if {[catch {FileInAccessPath $slave $file} msg]} { + Log $slave $msg; + return -code error "permission denied" + } + + # do the checks on the filename : + if {[catch {CheckFileName $slave $file} msg]} { + Log $slave "$file:$msg"; + return -code error $msg; + } + + # passed all the tests , lets source it: + if {[catch {::interp invokehidden $slave source $file} msg]} { + Log $slave $msg; + return -code error "script error"; + } + return $msg + } + + # AliasLoad is the target of the "load" alias in safe interpreters. + + proc AliasLoad {slave file args} { + + set argc [llength $args]; + if {$argc > 2} { + set msg "load error: too many arguments"; + Log $slave "$msg ($argc) {$file $args}"; + return -code error $msg; + } + + # package name (can be empty if file is not). + set package [lindex $args 0]; + + # Determine where to load. load use a relative interp path + # and {} means self, so we can directly and safely use passed arg. + set target [lindex $args 1]; + if {[string length $target]} { + # we will try to load into a sub sub interp + # check that we want to authorize that. + if {![NestedOk $slave]} { + Log $slave "loading to a sub interp (nestedok)\ + disabled (trying to load $package to $target)"; + return -code error "permission denied (nested load)"; + } + + } + + # Determine what kind of load is requested + if {[string length $file] == 0} { + # static package loading + if {[string length $package] == 0} { + set msg "load error: empty filename and no package name"; + Log $slave $msg; + return -code error $msg; + } + if {![StaticsOk $slave]} { + Log $slave "static packages loading disabled\ + (trying to load $package to $target)"; + return -code error "permission denied (static package)"; + } + } else { + # file loading + + # get the real path from the virtual one. + if {[catch {set file [TranslatePath $slave $file]} msg]} { + Log $slave $msg; + return -code error "permission denied" + } + + # check the translated path + if {[catch {FileInAccessPath $slave $file} msg]} { + Log $slave $msg; + return -code error "permission denied (path)" + } + } + + if {[catch {::interp invokehidden\ + $slave load $file $package $target} msg]} { + Log $slave $msg; + return -code error $msg + } + + return $msg + } + + # FileInAccessPath raises an error if the file is not found in + # the list of directories contained in the (master side recorded) slave's + # access path. + + # the security here relies on "file dirname" answering the proper + # result.... needs checking ? + proc FileInAccessPath {slave file} { + + set access_path [GetAccessPath $slave]; + + if {[file isdirectory $file]} { + error "\"$file\": is a directory" + } + set parent [file dirname $file] + if {[lsearch -exact $access_path $parent] == -1} { + error "\"$file\": not in access_path"; + } + } + + # This procedure enables access from a safe interpreter to only a subset of + # the subcommands of a command: + + proc Subset {slave command okpat args} { + set subcommand [lindex $args 0] + if {[regexp $okpat $subcommand]} { + return [eval {$command $subcommand} [lrange $args 1 end]] + } + set msg "not allowed to invoke subcommand $subcommand of $command"; + Log $slave $msg; + error $msg; + } + + # This procedure installs an alias in a slave that invokes "safesubset" + # in the master to execute allowed subcommands. It precomputes the pattern + # of allowed subcommands; you can use wildcards in the pattern if you wish + # to allow subcommand abbreviation. + # + # Syntax is: AliasSubset slave alias target subcommand1 subcommand2... + + proc AliasSubset {slave alias target args} { + set pat ^(; set sep "" + foreach sub $args { + append pat $sep$sub + set sep | + } + append pat )\$ + ::interp alias $slave $alias {}\ + [namespace current]::Subset $slave $target $pat + } + +} --- electric-6.05.orig/lib/java/COM/staticfreesoft/electric.java +++ electric-6.05/lib/java/COM/staticfreesoft/electric.java @@ -0,0 +1,189 @@ +// To compile this code: +// Run "Command prompt" +// cd "E:\DevelE\Electric\lib\java\COM\staticfreesoft" +// type "javac electric.java" + +package COM.staticfreesoft; + + +public class electric +{ + final static public int vdisplay = 64; + + int address; + + public class nodeinst extends electric {} + public class nodeproto extends electric {} + public class portarcinst extends electric {} + public class portexpinst extends electric {} + public class portproto extends electric {} + public class arcinst extends electric {} + public class arcproto extends electric {} + public class geom extends electric {} + public class library extends electric {} + public class technology extends electric {} + public class aid extends electric {} + public class rtnode extends electric {} + public class network extends electric {} + public class cell extends electric {} + public class view extends electric {} + public class windowpart extends electric {} + public class windowframe extends electric {} + public class graphics extends electric {} + public class constraint extends electric {} + public class polygon extends electric {} + public class xarray + { + public int[] v; + } + + public class eout extends java.io.PrintStream + { + public eout() { super(System.out); } + public void takeover() { System.setOut(this); System.setErr(this); } + + public native void ewrite(String s); + public native void write(int b); + + public boolean checkError() { return(false); } + public void flush() {} + public void print(boolean b) { ewrite(b ? "true" : "false"); } + public void print(char c) { ewrite(String.valueOf(c)); } + public void print(int i) { ewrite(String.valueOf(i)); } + public void print(long l) { ewrite(String.valueOf(l)); } + public void print(float f) { ewrite(String.valueOf(f)); } + public void print(double d) { ewrite(String.valueOf(d)); } + public void print(char s[]) { for (int i = 0; i < s.length; i++) write(s[i]); } + public void print(String s) { if (s == null) s = "null"; ewrite(s); } + public void print(Object o) { ewrite(String.valueOf(o)); } + public void println() { write('\n'); } + public void println(boolean x) { print(x); write('\n'); } + public void println(char x) { print(x); write('\n'); } + public void println(int x) { print(x); write('\n'); } + public void println(long x) { print(x); write('\n'); } + public void println(float x) { print(x); write('\n'); } + public void println(double x) { print(x); write('\n'); } + public void println(char x[]) { print(x); write('\n'); } + public void println(String x) { print(x); write('\n'); } + public void println(Object x) { print(x); write('\n'); } + public void write(byte[] s, int off, int len) + { for (int i = 0; i < len; i++) write(s[i+off]); } + } + + public boolean isNull() { return(address == -1); } + public static boolean isEqual(electric a1, electric a2) { return(a1.address == a2.address); } + + /***************** DATABASE EXAMINATION ROUTINES *****************/ + public static native library curLib(); + public static native technology curTech(); + public static native Object getVal(nodeinst obj, String name); + public static native Object getVal(nodeproto obj, String name); + public static native Object getVal(portarcinst obj, String name); + public static native Object getVal(portexpinst obj, String name); + public static native Object getVal(portproto obj, String name); + public static native Object getVal(arcinst obj, String name); + public static native Object getVal(arcproto obj, String name); + public static native Object getVal(geom obj, String name); + public static native Object getVal(library obj, String name); + public static native Object getVal(technology obj, String name); + public static native Object getVal(aid obj, String name); + public static native Object getVal(rtnode obj, String name); + public static native Object getVal(network obj, String name); + public static native Object getVal(cell obj, String name); + public static native Object getVal(view obj, String name); + public static native Object getVal(windowpart obj, String name); + public static native Object getVal(windowframe obj, String name); + public static native Object getVal(graphics obj, String name); + public static native Object getVal(constraint obj, String name); + public static native Object getVal(polygon obj, String name); + public static native void setVal(Object obj, String name, Object attr, int bits); + public static native void setInd(Object obj, String name, int index, Object attr); + public static native void delVal(Object obj, String name); + public static native int initSearch(int lx, int hx, int ly, int hy, nodeproto facet); + public static native Object nextObject(int search); + public static native void termSearch(int search); + + /***************** AID ROUTINES *****************/ + public static native aid getAid(String name); + public static native int maxAid(); + public static native aid indexAid(int index); + public static native void aidTurnOn(aid a, int noCatchUp); + public static native void aidTurnOff(aid a); + public static native void tellAid(aid a, int argc, String[] argv); + + /***************** LIBRARY ROUTINES *****************/ + public static native library getLibrary(String name); + public static native library newLibrary(String libname, String libfile); + public static native void killLibrary(library lib); + public static native void eraseLibrary(library lib); + public static native void selectLibrary(library lib); + + /***************** NODEPROTO ROUTINES *****************/ + public static native nodeproto getNodeProto(String name); + public static native nodeproto newNodeProto(String name, library lib); + public static native int killNodeProto(nodeproto facet); + public static native nodeproto copyNodeProto(nodeproto facet, library tolibrary, + String toname); + public static native nodeproto iconView(nodeproto facet); + public static native nodeproto contentsView(nodeproto facet); + + /***************** NODEINST ROUTINES *****************/ + public static native nodeinst newNodeInst(nodeproto proto, int lx, int hx, + int ly, int hy, int trans, int rot, nodeproto facet); + public static native void modifyNodeInst(nodeinst node, int dlx, int dly, + int dhx, int dhy, int drot, int dtrans); + public static native int killNodeInst(nodeinst node); + public static native nodeinst replaceNodeInst(nodeinst node, nodeproto newproto); + public static native int nodeFunction(nodeinst node); + public static native int nodePolys(nodeinst node); + public static native electric.polygon shapeNodePoly(nodeinst node, int index); + public static native int nodeEPolys(nodeinst node); + public static native electric.polygon shapeENodePoly(nodeinst node, int index); + public static native electric.xarray makeRot(nodeinst node); + public static native electric.xarray makeTrans(nodeinst node); + + /***************** ARCINST ROUTINES *****************/ + public static native arcinst newArcInst(arcproto proto, int wid, int bits, + nodeinst node1, portproto port1, int x1, int y1, + nodeinst node2, portproto port2, int x2, int y2, nodeproto facet); + public static native int modifyArcInst(arcinst arc, int dwid, int dx1, int dy1, + int dx2, int dy2); + public static native int killArcInst(arcinst arc); + public static native arcinst replaceArcInst(arcinst arc, arcproto newproto); + public static native int arcPolys(arcinst arc); + public static native electric.polygon shapeArcPoly(arcinst arc, int index); + + /***************** PORTPROTO ROUTINES *****************/ + public static native portproto newPortProto(nodeproto facet, nodeinst node, + portproto port, String name); + public static native Integer[] portPosition(nodeinst node, portproto port); + public static native portproto getPortProto(nodeproto facet, String name); + public static native int killPortProto(nodeproto facet, portproto port); + public static native int movePortProto(nodeproto facet, portproto oldport, + nodeinst newnode, portproto newport); + + /***************** CHANGE CONTROL ROUTINES *****************/ + public static native int undoABatch(); + public static native void noUndoAllowed(); + + /***************** VIEW ROUTINES *****************/ + public static native view getView(String name); + public static native view newView(String name, String shortname); + public static native int killView(view v); + + /***************** MISCELLANEOUS ROUTINES *****************/ + public static native arcproto getArcProto(String name); + public static native cell getCell(String name); + public static native technology getTechnology(String name); + public static native nodeproto getPinProto(arcproto arctype); + public static native network getNetwork(String name, nodeproto facet); + public static native String layerName(technology tech, int layer); + public static native int layerFunction(technology tech, int layer); + public static native int maxDRCSurround(technology tech, library lib, int layer); + public static native int DRCMinDistance(technology tech, library lib, int layer1, + int layer2, int connected); + public static native int DRCMinWidth(technology tech, library lib, int layer); + public static native void xformPoly(polygon poly, xarray trans); + public static native void freePolygon(polygon poly); + public static native electric.nodeinst[] getTraversalPath(); +} --- electric-6.05.orig/lib/lisp/xwidgets.scm +++ electric-6.05/lib/lisp/xwidgets.scm @@ -0,0 +1,54 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme part of the X11 widget interface. + +(require 'xt) + +(define widget-subdirectory 'xaw) + +(define load-always '()) + +(define widget-aliases #f) + +(define (widget-loaded? w) + (feature? (string->symbol (format #f "~a:~a.o" widget-subdirectory w)))) + +(define-macro (load-widgets . w) + (let ((wl '()) (l '())) + (if (null? w) + (error 'load-widgets "no arguments")) + (for-each + (lambda (w) + (if (not (symbol? w)) + (error 'load-widgets "argument not a symbol")) + (if (not (widget-loaded? w)) + (set! l (cons w l)))) + w) + (for-each + (lambda (w) + (if (not (widget-loaded? w)) + (set! l (cons w l)))) + load-always) + (if (not (null? l)) + (begin + (if (not widget-aliases) + (load (format #f "~a/ALIASES" widget-subdirectory))) + (format #t "[Loading ") + (do ((f l (cdr f))) ((null? f)) + (let* ((file (car f)) + (alias (assq (car f) widget-aliases))) + (if alias (set! file (cdr alias))) + (format #t "~a~a" file (if (null? (cdr f)) "" " ")) + (set! wl (cons (format #f "~a/~a.o" widget-subdirectory file) + wl)))) + (format #t "]~%") + `(fluid-let ((load-libraries + (if (feature? 'motif) + (string-append site-lib-xmotif " " load-libraries) + (string-append site-lib-xaw " " load-libraries)))) + (load ',wl))) + #f))) + +(define load-widget load-widgets) + +(provide 'xwidgets) --- electric-6.05.orig/lib/lisp/struct.scm +++ electric-6.05/lib/lisp/struct.scm @@ -0,0 +1,120 @@ +;;; -*-Scheme-*- +;;; +;;; The `strucuture' extension is obsolete and should not be used in +;;; applications any longer; it has been replaced by the more powerful +;;; `record' extension. +;;; +;;; The Scheme part of the structures implementation +;;; +;;; (define-structure name slot slot ...) +;;; +;;; slot = slot-name or (slot-name initial-value) + +(require 'struct.o) + +(define-macro (define-structure name . slot-descr) + (internal-define-structure name slot-descr #t)) + +(define-macro (define-simple-structure name . slot-descr) + (internal-define-structure name slot-descr #f)) + +(define (internal-define-structure name slot-descr full?) + (if (not (symbol? name)) + (error 'define-structure "structure name must be a symbol")) + (if (null? slot-descr) + (error 'define-structure "structure has no slots")) + (let* ((s (symbol->string name)) + (constructor + (string->symbol (string-append "make-" s))) + (predicator + (string->symbol (string-append s "?"))) + (copier + (string->symbol (string-append "copy-" s))) + (slots '()) (arg-slots '())) + (for-each + (lambda (slot) + (cond ((symbol? slot) + (set! slots (cons slot slots)) + (set! arg-slots (cons slot arg-slots))) + ((pair? slot) + (if (or (not (pair? (cdr slot))) + (not (null? (cddr slot)))) + (error 'define-structure "invalid slot specification") + (if (not (symbol? (car slot))) + (error 'define-structure "slot name must be a symbol")) + (set! slots (cons (car slot) slots)))) + (else + (error 'define-structure "slot must be symbol or list")))) + slot-descr) + (set! slots (reverse slots)) + `(begin + (make-constructor ,constructor ,name ,slots + ,(reverse arg-slots) ,slot-descr) + (make-predicator ,predicator ',name) + (make-copier ,copier) + ,@(let ((offset -1)) + (map + (lambda (slot) + (let ((f + (string->symbol (format #f "~s-~s" name slot)))) + (set! offset (1+ offset)) + `(make-accessor ,f ',name ,offset))) + slots)) + ,@(if full? (let ((offset -1)) + (map + (lambda (slot) + (let ((f + (string->symbol (format #f "set-~s-~s!" name slot)))) + (set! offset (1+ offset)) + `(make-mutator ,f ',name ,offset))) + slots))) + ',name))) + +(define-macro (make-constructor constructor name slots arg-slots descr) + `(define (,constructor ,@arg-slots) + (let ((,name (make-structure ',name ',slots))) + ,@(let ((offset -1)) + (map + (lambda (slot) + (set! offset (1+ offset)) + `(structure-set! ,name ',name ,offset + ,(if (symbol? slot) + slot + (cadr slot)))) + descr)) + ,name))) + +(define-macro (make-predicator predicator name) + `(define (,predicator x) + (and (structure? x) (eq? (structure-name x) ,name)))) + +(define-macro (make-copier copier) + `(define (,copier x) + (copy-structure x))) + +(define-macro (make-accessor accessor name offset) + `(define (,accessor x) + (structure-ref x ,name ,offset))) + +(define-macro (make-mutator mutator name offset) + `(define (,mutator x val) + (structure-set! x ,name ,offset val))) + +(define (copy-structure s) + (let* ((slots (structure-slots s)) + (name (structure-name s)) + (new (make-structure name slots)) + (size (length slots))) + (do ((offset 0 (1+ offset))) ((= offset size) new) + (structure-set! new name offset (structure-ref s name offset))))) + +(define (describe-structure s) + (format #t "a structure of type ~s.~%" (structure-name s)) + (if (null? (structure-slots s)) + (format #t "It has no slots.~%") + (format #t "Its slots are:") + (for-each (lambda (s v) (format #t " (~s ~s)" s v)) + (structure-slots s) (structure-values s)) + (format #t ".~%"))) + +(provide 'struct) --- electric-6.05.orig/lib/lisp/Makefile +++ electric-6.05/lib/lisp/Makefile @@ -0,0 +1,25 @@ +SHELL=/bin/sh +MAKE=make + +all: default + +Makefile.local: ../config/system ../config/site + $(SHELL) ./build + +default: Makefile.local + $(MAKE) -f Makefile.local + +install: Makefile.local + $(MAKE) -f Makefile.local install + +localize: Makefile.local + $(MAKE) -f Makefile.local localize + +lint: Makefile.local + $(MAKE) -f Makefile.local lint + +clean: Makefile.local + $(MAKE) -f Makefile.local clean + +distclean: Makefile.local + $(MAKE) -f Makefile.local distclean --- electric-6.05.orig/lib/lisp/qsort.scm +++ electric-6.05/lib/lisp/qsort.scm @@ -0,0 +1,32 @@ +;;; -*-Scheme-*- +;;; +;;; Quicksort (straight from Wirth, Algorithmen & Datenstrukturen, p. 117) + +(provide 'sort) + +(define (sort obj pred) + (if (vector? obj) + (sort! (vector-copy obj) pred) + (vector->list (sort! (list->vector obj) pred)))) + +(define (sort! v pred) + (define (internal-sort l r) + (let ((i l) (j r) (x (vector-ref v (quotient (1- (+ l r)) 2)))) + (let loop () + (do () ((not (pred (vector-ref v i) x))) (set! i (1+ i))) + (do () ((not (pred x (vector-ref v j)))) (set! j (1- j))) + (if (<= i j) + (begin + (vector-set! v j (vector-set! v i (vector-ref v j))) + (set! i (1+ i)) + (set! j (1- j)))) + (if (<= i j) + (loop))) + (if (< l j) + (internal-sort l j)) + (if (< i r) + (internal-sort i r)))) + (let ((len (vector-length v))) + (if (> len 1) + (internal-sort 0 (1- len))) + v)) --- electric-6.05.orig/lib/lisp/safe-env.scm +++ electric-6.05/lib/lisp/safe-env.scm @@ -0,0 +1,15 @@ +;;; -*-Scheme-*- +;;; +;;; This macro evaluates its arguments (arbitrary expressions) in a +;;; lexical environment created as a copy of the global environment +;;; in which all the predefined primitives are bound. +;;; Contributed by Carsten Bormann + +(define-macro (with-safe-environment . body) + (let* ((built-in-environment + (car (last-pair (environment->list (the-environment))))) + (binding-copy + (map (lambda (p) + (list (car p) (car p))) + built-in-environment)) ) + `(let ,binding-copy ,@body))) --- electric-6.05.orig/lib/lisp/parse.scm +++ electric-6.05/lib/lisp/parse.scm @@ -0,0 +1,16 @@ +;;; -*-Scheme-*- +;;; +;;; string-tokenize -- parse a string into a list of tokens + +(define (string-tokenize s) + (let ((i 0) (j) + (n (string-length s))) + (let loop ((args '())) + (while (and (< i n) (char-whitespace? (string-ref s i))) + (set! i (1+ i))) + (if (>= i n) + (reverse! args) + (set! j i) + (while (and (< i n) (not (char-whitespace? (string-ref s i)))) + (set! i (1+ i))) + (loop (cons (substring s j i) args)))))) --- electric-6.05.orig/lib/lisp/unix.scm +++ electric-6.05/lib/lisp/unix.scm @@ -0,0 +1,174 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme layer of the UNIX extension. + +(require 'record) +(require 'recordutil) +(require 'unix.o) + +(define-record-type stat (type mode ino dev nlink uid gid size + atime mtime ctime)) +(define-record-accessors stat-record) + +(define (unix-stat fn) + (let* ((ret (make-stat-record)) + (err (unix-stat-vector-fill! fn (record-values ret)))) + (if (unix-error? err) err ret))) + +(if (feature? 'unix:symlinks) + (define (unix-lstat fn) + (let* ((ret (make-stat-record)) + (err (unix-lstat-vector-fill! fn (record-values ret)))) + (if (unix-error? err) err ret)))) + + +(define-record-type time (seconds minutes hours day-of-month month year + weekday day-of-year dst)) +(define-record-accessors time-record) +(define-record-modifiers time-record) + +(define (unix-decode-localtime t) + (let ((ret (make-time-record))) + (unix-decode-time-vector-fill! t (record-values ret) #f) + ret)) + +(define (unix-decode-utc t) + (let ((ret (make-time-record))) + (unix-decode-time-vector-fill! t (record-values ret) #t) + ret)) + +(define (unix-time->string t) + (cond + ((integer? t) + (unix-time->string-internal t)) + ((time-record? t) + (unix-time->string-internal (record-values t))) + (else + (error 'unix-time->string "argument must be integer or time-record")))) + + +(define-record-type nanotime (nanoseconds minuteswest dst)) +(define-record-accessors nanotime-record) + +(define (unix-internal-make-nanotime v i) + (if (vector-ref v i) + (vector-set! v i (+ (* (car (vector-ref v i)) 1000000000) + (cdr (vector-ref v i)))))) + +(define (unix-nanotime) + (let* ((ret (make-nanotime-record)) + (v (record-values ret))) + (unix-nanotime-vector-fill! v) + (vector-set! v 0 (+ (* (car (vector-ref v 0)) 1000000000) + (cdr (vector-ref v 0)))) + ret)) + + +(define-record-type system (hostname sysname osname)) +(define-record-accessors system-record) + +(define (unix-system-info) + (let ((ret (make-system-record))) + (unix-system-info-vector-fill! (record-values ret)) + ret)) + + +(define-record-type passwd (name password uid gid gecos homedir shell)) +(define-record-accessors passwd-record) + +(define (unix-get-passwd . arg) + (let* ((ret (make-passwd-record)) + (err (apply unix-get-passwd-vector-fill! (record-values ret) arg))) + (if (unix-error? err) err ret))) + + +(define-record-type group (name password gid members)) +(define-record-accessors group-record) + +(define (unix-get-group . arg) + (let* ((ret (make-group-record)) + (err (apply unix-get-group-vector-fill! (record-values ret) arg))) + (if (unix-error? err) err ret))) + + +(define-record-type resources (user-time system-time)) +(define-record-accessors resources-record) + +(define (unix-process-resources) + (let* ((self (make-resources-record)) + (children (make-resources-record)) + (v1 (record-values self)) + (v2 (record-values children)) + (ticks/s (unix-process-resources-vector-fill! v1 v2)) + (convert (lambda (ticks) (round (/ (* ticks 1000000000) ticks/s))))) + (vector-set! v1 0 (convert (vector-ref v1 0))) + (vector-set! v1 1 (convert (vector-ref v1 1))) + (vector-set! v2 0 (convert (vector-ref v2 0))) + (vector-set! v2 1 (convert (vector-ref v2 1))) + (cons self children))) + + +(if (feature? 'unix:file-locking) + (begin + (define-record-type lock (exclusive? whence start length)) + (define-record-accessors lock-record) + (define-record-modifiers lock-record) + + (define (unix-set-lock fd lock wait?) + (if (not (lock-record? lock)) + (error 'unix-set-lock "argument not a lock-record")) + (unix-internal-lock-operation fd (record-values lock) wait? #\s 0)) + + (define (unix-remove-lock fd lock) + (if (not (lock-record? lock)) + (error 'unix-remove-lock "argument not a lock-record")) + (unix-internal-lock-operation fd (record-values lock) #f #\r 0)) + + (define (unix-query-lock fd lock) + (if (not (lock-record? lock)) + (error 'unix-remove-lock "argument not a lock-record")) + (let* ((ret (make-lock-record)) + (pid (unix-internal-lock-operation fd (record-values lock) + #f #\q (record-values ret)))) + (if pid + (cons pid ret) + #f))))) + + +(define-record-type wait (pid status code core-dump? resources)) +(define-record-accessors wait-record) + +(define (unix-wait . options) + (let* ((ret (make-wait-record)) + (resources ((record-constructor resources-record) #f #f)) + (v (record-values ret)) + (rv (record-values resources)) + (err (apply unix-wait-vector-fill! v rv options))) + (unix-internal-make-nanotime rv 0) + (unix-internal-make-nanotime rv 1) + (vector-set! v 4 resources) + (if (unix-error? err) err ret))) + +(if (feature? 'unix:wait-process) + (define (unix-wait-process pid . options) + (let* ((ret (make-wait-record)) + (resources ((record-constructor resources-record) #f #f)) + (v (record-values ret)) + (rv (record-values resources)) + (err (apply unix-wait-process-vector-fill! v rv pid options))) + (unix-internal-make-nanotime rv 0) + (unix-internal-make-nanotime rv 1) + (vector-set! v 4 resources) + (if (unix-error? err) err ret)))) + + +(define (unix-perror str) + (format #t "~a: ~E" str)) + +(define-macro (unix-errval expr) + `(fluid-let ((unix-call-standard-error-handler? #f)) + ,expr)) + +;; also need the opposite of unix-errval (i.e. make sure error is handled) + +(provide 'unix) --- electric-6.05.orig/lib/lisp/build +++ electric-6.05/lib/lisp/build @@ -0,0 +1,66 @@ +. ../config/system +. ../config/site + +echo Building Makefile.local... +cat >Makefile.local < (length args) 1) + (error 'backtrace "too many arguments")) + (if (not (null? args)) + (if (not (eq? (type (car args)) 'control-point)) + (error 'backtrace "argument must be a control point"))) + (let ((trace + (apply backtrace-list args)) + (maxlen 28)) + (if (null? args) + (set! trace (cdddr trace))) + (for-each + (lambda (frame) + (let* ((func + (format #f "~s" (vector-ref frame 0))) + (indent + (- maxlen (string-length func)))) + (display func) + (if (negative? indent) + (begin + (newline) + (set! indent maxlen))) + (do ((i indent (1- i))) + ((> 0 i)) + (display " "))) + (fluid-let + ((print-depth 2) + (print-length 3)) + (display (vector-ref frame 1))) + (newline)) + trace)) + #v) + +(define (show env) + (fluid-let + ((print-length 2) + (print-depth 2)) + (do ((f (environment->list env) (cdr f))) + ((null? f)) + (do ((b (car f) (cdr b))) + ((null? b)) + (format #t "~s\t~s~%" (caar b) (cdar b))) + (print '-------))) + #v) + +(define inspect) + +(let ((frame) + (trace) + (help-text + '("q -- quit inspector" + "f -- print current frame" + "u -- go up one frame" + "d -- go down one frame" + "^ -- go to top frame" + "$ -- go to bottom frame" + "e -- eval expressions in environment" + "p -- pretty-print procedure" + "v -- show environment" + " -- pretty-print n-th argument" + "o -- obarray information"))) + + (define (inspect-command-loop) + (let ((input) (done #f)) + (display "inspect> ") + (set! input (read)) + (case input + (q + (set! done #t)) + (? + (for-each + (lambda (msg) + (display msg) + (newline)) + help-text)) + (f + (print-frame)) + (^ + (set! frame 0) + (print-frame)) + ($ + (set! frame (1- (length trace))) + (print-frame)) + (u + (if (zero? frame) + (format #t "Already on top frame.~%") + (set! frame (1- frame)) + (print-frame))) + (d + (if (= frame (1- (length trace))) + (format #t "Already on bottom frame.~%") + (set! frame (1+ frame)) + (print-frame))) + (v + (show (vector-ref (list-ref trace frame) 2))) + (e + (format #t "Type ^D to return to Inspector.~%") + (let loop () + (display "eval> ") + (set! input (read)) + (if (not (eof-object? input)) + (begin + (write (eval input + (vector-ref (list-ref trace frame) 2))) + (newline) + (loop)))) + (newline)) + (p + (pp (vector-ref (list-ref trace frame) 0)) + (newline)) + (o + (let ((l (map length (oblist)))) + (let ((n 0)) + (for-each (lambda (x) (set! n (+ x n))) l) + (format #t "~s symbols " n) + (format #t "(maximum bucket: ~s).~%" (apply max l))))) + (else + (cond + ((integer? input) + (let ((args (vector-ref (list-ref trace frame) 1))) + (if (or (< input 1) (> input (length args))) + (format #t "No such argument.~%") + (pp (list-ref args (1- input))) + (newline)))) + ((eof-object? input) + (set! done #t)) + (else + (format #t "Invalid command. Type ? for help.~%"))))) + (if (not done) + (inspect-command-loop)))) + + (define (print-frame) + (format #t "~%Frame ~s of ~s:~%~%" (1+ frame) (length trace)) + (let* ((f (list-ref trace frame)) (args (vector-ref f 1))) + (format #t "Procedure: ~s~%" (vector-ref f 0)) + (format #t "Environment: ~s~%" (vector-ref f 2)) + (if (null? args) + (format #t "No arguments.~%") + (fluid-let + ((print-depth 2) + (print-length 3)) + (do ((i 1 (1+ i)) (args args (cdr args))) ((null? args)) + (format #t "Argument ~s: ~s~%" i (car args)))))) + (newline)) + + (set! inspect + (lambda () + (set! frame 0) + (set! trace (backtrace-list)) + (set! trace (cddr trace)) + (do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t)) + (if (not (null? (vector-ref (car t) 1))) + (let ((last (last-pair (vector-ref (car t) 1)))) + (if (not (null? (cdr last))) + (begin + (format #t + "[inspector: fixing improper arglist in frame ~s]~%" f) + (set-cdr! last (cons (cdr last) '()))))))) + (format #t "Inspector (type ? for help):~%") + (let loop () + (if (call-with-current-continuation + (lambda (control-point) + (push-frame control-point) + (inspect-command-loop) + #f)) + (begin + (pop-frame) + (loop)))) + (newline) + (pop-frame) + (let ((next-frame (car rep-frames))) + (next-frame #t))))) + --- electric-6.05.orig/lib/lisp/cscheme.scm +++ electric-6.05/lib/lisp/cscheme.scm @@ -0,0 +1,138 @@ +;;; -*-Scheme-*- +;;; +;;; A few C-Scheme compatibility hacks + +(provide 'cscheme) + +(define-macro (syntax-table-define table name mac) + `(define ,(eval name) ,mac)) + +(define mapcar map) + +(define user-initial-environment (global-environment)) + +(define (rep-environment) (global-environment)) + +(define (atom? x) + (not (pair? x))) + +(define nil '()) + +(define *the-non-printing-object* #v) + +(define (integer->string i) + (format #f "~s" i)) + +(define (get* sym prop) + (let ((ret (get sym prop))) + (if ret ret '()))) + +(define-macro (access sym env) + `(eval ',sym ,env)) + +(define-macro (in-package env . body) + `(eval '(begin ,@body) ,env)) + +(define-macro (without-interrupts thunk) + `(,thunk)) + +(define-macro (rec var exp) + `(letrec ((,var ,exp)) ,exp)) + +(define (cons* first . rest) + (let loop ((curr first) (rest rest)) + (if (null? rest) + curr + (cons curr (loop (car rest) (cdr rest)))))) + +(define sequence begin) + +(define -1+ 1-) + +(define (remq x y) + (cond ((null? y) y) + ((eq? x (car y)) (remq x (cdr y))) + (else (cons (car y) (remq x (cdr y)))))) + +(define (remv x y) + (cond ((null? y) y) + ((eqv? x (car y)) (remv x (cdr y))) + (else (cons (car y) (remv x (cdr y)))))) + +(define (remove x y) + (cond ((null? y) y) + ((equal? x (car y)) (remove x (cdr y))) + (else (cons (car y) (remove x (cdr y)))))) + +(define (remq! x y) + (cond ((null? y) y) + ((eq? x (car y)) (remq! x (cdr y))) + (else (let loop ((prev y)) + (cond ((null? (cdr prev)) + y) + ((eq? (cadr prev) x) + (set-cdr! prev (cddr prev)) + (loop prev)) + (else (loop (cdr prev)))))))) + +(define (remv! x y) + (cond ((null? y) y) + ((eqv? x (car y)) (remv! x (cdr y))) + (else (let loop ((prev y)) + (cond ((null? (cdr prev)) + y) + ((eqv? (cadr prev) x) + (set-cdr! prev (cddr prev)) + (loop prev)) + (else (loop (cdr prev)))))))) + +(define (remove! x y) + (cond ((null? y) y) + ((equal? x (car y)) (remove! x (cdr y))) + (else (let loop ((prev y)) + (cond ((null? (cdr prev)) + y) + ((equal? (cadr prev) x) + (set-cdr! prev (cddr prev)) + (loop prev)) + (else (loop (cdr prev)))))))) + +(define delq remq) +(define delv remv) +(define delete remove) +(define delq! remq!) +(define delv! remv!) +(define delete! remove!) + +(empty-list-is-false-for-backward-compatibility #t) + +(if (feature? 'bitstring) + (begin + (define (bit-string-allocate k) (make-bitstring k #f)) + (define bit-string-copy bitstring-copy) + (define bit-string? bitstring?) + (define bit-string-length bitstring-length) + (define bit-string-ref bitstring-ref) + (define (bit-string-set! b i) (bitstring-set! b i #t)) + (define (bit-string-clear! b i) (bitstring-set! b i #f)) + (define bit-string-append bitstring-append) + (define bit-substring bitstring-substring) + (define bit-string-zero? bitstring-zero?) + (define bit-string=? bitstring=?) + (define bit-string-not bitstring-not) + (define bit-string-movec! bitstring-not!) + (define bit-string-and bitstring-and) + (define bit-string-andc bitstring-andnot) + (define bit-string-or bitstring-or) + (define bit-string-xor bitstring-xor) + (define bit-string-and! bitstring-and!) + (define bit-string-or! bitstring-or!) + (define bit-string-xor! bitstring-xor!) + (define bit-string-andc! bitstring-andnot!) + (define bit-string-fill! bitstring-fill!) + (define bit-string-move! bitstring-move!) + (define bit-substring-move-right! bitstring-substring-move!) + (define unsigned-integer->bit-string unsigned-integer->bitstring) + (define signed-integer->bit-string signed-integer->bitstring) + (define bit-string->unsigned-integer bitstring->unsigned-integer) + (define bit-string->signed-integer bitstring->signed-integer))) --- electric-6.05.orig/lib/lisp/describe.scm +++ electric-6.05/lib/lisp/describe.scm @@ -0,0 +1,72 @@ +;;; -*-Scheme-*- +;;; +;;; describe -- print information about a Scheme object + +(define (describe x) + (fluid-let + ((print-depth 2) + (print-length 3)) + (format #t "~s is " (if (void? x) '\#v x))) + (case (type x) + (integer + (format #t "an integer.~%")) + (real + (format #t "a real.~%")) + (null + (format #t "an empty list.~%")) + (boolean + (format #t "a boolean value (~s).~%" (if x 'true 'false))) + (character + (format #t "a character, ascii value is ~s~%" (char->integer x))) + (symbol + (format #t "a symbol~a." (if (void? x) " (the non-printing object)" "")) + (let ((l (symbol-plist x))) + (if (null? l) + (format #t " It has no property list.~%") + (format #t "~%Its property list is: ~s.~%" l)))) + (pair + (if (pair? (cdr x)) + (let ((p (last-pair x))) + (if (null? (cdr p)) + (format #t "a list of length ~s.~%" (length x)) + (format #t "an improper list.~%"))) + (format #t "a pair.~%"))) + (environment + (format #t "an environment.~%")) + (string + (if (eqv? x "") + (format #t "an empty string.~%") + (format #t "a string of length ~s.~%" (string-length x)))) + (vector + (if (eqv? x '#()) + (format #t "an empty vector.~%") + (if (and (feature? 'oops) (memq (vector-ref x 0) + '(class instance))) + (if (eq? (vector-ref x 0) 'class) + (begin + (format #t "a class.~%~%") + (describe-class x)) + (format #t "an instance.~%~%") + (describe-instance x)) + (format #t "a vector of length ~s.~%" (vector-length x))))) + (primitive + (format #t "a primitive procedure.~%")) + (compound + (format #t "a compound procedure (type ~s).~%" + (car (procedure-lambda x)))) + (control-point + (format #t "a control point (continuation).~%")) + (promise + (format #t "a promise.~%")) + (port + (format #t "a port.~%")) + (end-of-file + (format #t "the end-of-file object.~%")) + (macro + (format #t "a macro.~%")) + (else + (let ((descr-func (string->symbol + (format #f "describe-~s" (type x))))) + (if (bound? descr-func) + ((eval descr-func) x) + (format #t "an object of unknown type (~s)~%" (type x))))))) --- electric-6.05.orig/lib/lisp/toplevel.scm +++ electric-6.05/lib/lisp/toplevel.scm @@ -0,0 +1,109 @@ +;;; -*-Scheme-*- +;;; +;;; Read-eval-print loop and error handler + + +(autoload 'pp 'pp.scm) +(autoload 'apropos 'apropos.scm) +(autoload 'sort 'qsort.scm) +(autoload 'describe 'describe.scm) +(autoload 'backtrace 'debug.scm) +(autoload 'inspect 'debug.scm) + +(define ?) +(define ??) +(define ???) +(define !) +(define !!) +(define !!!) +(define &) + +(define (rep-loop env) + (define input) + (define value) + (let loop () + (set! ??? ??) + (set! ?? ?) + (set! ? &) + ;;; X Windows hack + (if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy)) + (display-flush-output dpy)) + (if (> rep-level 0) + (display rep-level)) + (display "> ") + (set! input (read)) + (set! & input) + (if (not (eof-object? input)) + (begin + (set! value (eval input env)) + (set! !!! !!) + (set! !! !) + (set! ! value) + (write value) + (newline) + (loop))))) + +(define rep-frames) +(define rep-level) + +(set! interrupt-handler + (lambda () + (format #t "~%\7Interrupt!~%") + (let ((next-frame (car rep-frames))) + (next-frame #t)))) + +(define-macro (push-frame control-point) + `(begin + (set! rep-frames (cons ,control-point rep-frames)) + (set! rep-level (1+ rep-level)))) + +(define-macro (pop-frame) + '(begin + (set! rep-frames (cdr rep-frames)) + (set! rep-level (1- rep-level)))) + +(define (error-print error-msg) + (format #t "~s: " (car error-msg)) + (apply format `(#t ,@(cdr error-msg))) + (newline)) + +(set! error-handler + (lambda error-msg + (error-print error-msg) + (let loop ((intr-level (enable-interrupts))) + (if (positive? intr-level) + (loop (enable-interrupts)))) + (let loop () + (if (call-with-current-continuation + (lambda (control-point) + (push-frame control-point) + (rep-loop (the-environment)) + #f)) + (begin + (pop-frame) + (loop)))) + (newline) + (pop-frame) + (let ((next-frame (car rep-frames))) + (next-frame #t)))) + +(define top-level-environment (the-environment)) + +(define (top-level) + (let loop () + ;;; Allow GC to free old rep-frames when we get here on "reset": + (set! rep-frames (list top-level-control-point)) + (if (call-with-current-continuation + (lambda (control-point) + (set! rep-frames (list control-point)) + (set! top-level-control-point control-point) + (set! rep-level 0) + (rep-loop top-level-environment) + #f)) + (loop)))) + +(define (the-top-level) + (top-level) + (newline)) + +; don't call on load...call when requested...(the-top-level) --- electric-6.05.orig/lib/lisp/debug.scm +++ electric-6.05/lib/lisp/debug.scm @@ -0,0 +1,212 @@ +;;; -*-Scheme-*- +;;; +;;; A simple debugger (improvements by Thomas M. Breuel ). + +(define (backtrace . args) + (if (> (length args) 1) + (error 'backtrace "too many arguments")) + (if (not (null? args)) + (if (not (eq? (type (car args)) 'control-point)) + (error 'backtrace "argument must be a control point"))) + (let ((trace (apply backtrace-list args))) + (if (null? args) + (set! trace (cdddr trace))) + (show-backtrace trace 0 999999))) + +(define (show-backtrace trace start-frame end-frame) + (define (rjust n x) + (let* ((y (string-append (make-string n #\space) x)) + (l (string-length y))) + (substring y (- l n) l))) + (let ((maxlen 28)) + (let loop ((frames (list-tail trace start-frame)) (num start-frame)) + (if (or (null? frames) (>= num end-frame)) #v + (let ((frame (car frames))) + (let* ((func + (format #f "~s" (vector-ref frame 0))) + (indent + (- maxlen (+ 5 (string-length func))))) + (display (rjust 4 (number->string num))) + (display " ") + (display func) + (if (negative? indent) + (begin + (newline) + (set! indent maxlen))) + (do ((i indent (1- i))) + ((> 0 i)) + (display " "))) + (fluid-let + ((print-depth 2) + (print-length 3)) + (display (vector-ref frame 1))) + (newline)) + (loop (cdr frames) (1+ num)))))) + +(define (show-environment env) + (fluid-let + ((print-length 2) + (print-depth 2)) + (do ((f (environment->list env) (cdr f))) + ((null? f)) + (do ((b (car f) (cdr b))) + ((null? b)) + (format #t "~s\t~s~%" (caar b) (cdar b))) + (print '-------))) + #v) + +(define inspect) + +(let ((frame) + (trace) + (help-text + '("q -- quit inspector" + "f -- print current frame" + "u -- go up one frame" + "d -- go down one frame" + "^ -- go to top frame" + "$ -- go to bottom frame" + "g -- goto to n-th frame" + "e -- eval expressions in environment" + "p -- pretty-print procedure" + "v -- show environment" + " -- pretty-print n-th argument" + "b -- show backtrace starting at current frame" + "t -- show top of bracktrace starting at current frame" + "z -- show and move top of backtrace starting at current frame" + "o -- obarray information"))) + + (define (inspect-command-loop) + (let ((input) (done #f)) + (display "inspect> ") + (set! input (read)) + (case input + (q + (set! done #t)) + (? + (for-each + (lambda (msg) + (display msg) + (newline)) + help-text)) + (f + (print-frame)) + (^ + (set! frame 0) + (print-frame)) + ($ + (set! frame (1- (length trace))) + (print-frame)) + (u + (if (zero? frame) + (format #t "Already on top frame.~%") + (set! frame (1- frame)) + (print-frame))) + (d + (if (= frame (1- (length trace))) + (format #t "Already on bottom frame.~%") + (set! frame (1+ frame)) + (print-frame))) + (g + (set! input (read)) + (if (integer? input) + (set! frame + (cond ((negative? input) 0) + ((>= input (length trace)) (1- (length trace))) + (else input))) + (format #t "Frame number must be an integer.~%"))) + (v + (show-environment (vector-ref (list-ref trace frame) 2))) + (e + (format #t "Type ^D to return to Inspector.~%") + (let loop () + (display "eval> ") + (set! input (read)) + (if (not (eof-object? input)) + (begin + (write (eval input + (vector-ref (list-ref trace frame) 2))) + (newline) + (loop)))) + (newline)) + (p + (pp (vector-ref (list-ref trace frame) 0)) + (newline)) + (z + (show-backtrace trace frame (+ frame 10)) + (set! frame (+ frame 9)) + (if (>= frame (length trace)) (set! frame (1- (length trace))))) + (t + (show-backtrace trace frame (+ frame 10))) + (b + (show-backtrace trace frame 999999)) + (o + (let ((l (map length (oblist)))) + (let ((n 0)) + (for-each (lambda (x) (set! n (+ x n))) l) + (format #t "~s symbols " n) + (format #t "(maximum bucket: ~s).~%" (apply max l))))) + (else + (cond + ((integer? input) + (let ((args (vector-ref (list-ref trace frame) 1))) + (if (or (< input 1) (> input (length args))) + (format #t "No such argument.~%") + (pp (list-ref args (1- input))) + (newline)))) + ((eof-object? input) + (set! done #t)) + (else + (format #t "Invalid command. Type ? for help.~%"))))) + (if (not done) + (inspect-command-loop)))) + + (define (print-frame) + (format #t "~%Frame ~s of ~s:~%~%" frame (1- (length trace))) + (let* ((f (list-ref trace frame)) (args (vector-ref f 1))) + (format #t "Procedure: ~s~%" (vector-ref f 0)) + (format #t "Environment: ~s~%" (vector-ref f 2)) + (if (null? args) + (format #t "No arguments.~%") + (fluid-let + ((print-depth 2) + (print-length 3)) + (do ((i 1 (1+ i)) (args args (cdr args))) ((null? args)) + (format #t "Argument ~s: ~s~%" i (car args)))))) + (newline)) + + (define (find-frame proc) + (let loop ((l trace) (i 0)) + (cond ((null? l) -1) + ((eq? (vector-ref (car l) 0) proc) i) + (else (loop (cdr l) (1+ i)))))) + + (set! inspect + (lambda () + (set! trace (backtrace-list)) + (set! trace (cddr trace)) + (do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t)) + (if (not (null? (vector-ref (car t) 1))) + (let ((last (last-pair (vector-ref (car t) 1)))) + (if (not (null? (cdr last))) + (begin + (format #t + "[inspector: fixing improper arglist in frame ~s]~%" f) + (set-cdr! last (cons (cdr last) '()))))))) + (set! frame (find-frame error-handler)) + (if (negative? frame) + (set! frame 0)) + (format #t "Inspector (type ? for help):~%") + (let loop () + (if (call-with-current-continuation + (lambda (control-point) + (push-frame control-point) + (inspect-command-loop) + #f)) + (begin + (pop-frame) + (loop)))) + (newline) + (pop-frame) + (let ((next-frame (car rep-frames))) + (next-frame #t))))) --- electric-6.05.orig/lib/lisp/bitstring.scm +++ electric-6.05/lib/lisp/bitstring.scm @@ -0,0 +1,59 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme layer of the bitstring extension. + +(require 'bitstring.o) + +(define (bitstring-copy b) + (let ((new (make-bitstring (bitstring-length b) #f))) + (bitstring-move! new b) + new)) + +(define (bitstring-append a b) + (let* ((alen (bitstring-length a)) + (blen (bitstring-length b)) + (new (make-bitstring (+ alen blen) #f))) + (bitstring-substring-move! a 0 alen new 0) + (bitstring-substring-move! b 0 blen new alen) + new)) + +(define (bitstring-substring b from to) + (let ((new (make-bitstring (- to from) #f))) + (bitstring-substring-move! b from to new 0) + new)) + +(define (bitstring-not b) + (let ((new (bitstring-copy b))) + (bitstring-not! new b) + new)) + +(define (bitstring-make-logical-function fun!) + (lambda (a b) + (let ((new (bitstring-copy a))) + (fun! new b) + new))) + +(define bitstring-and (bitstring-make-logical-function bitstring-and!)) +(define bitstring-andnot (bitstring-make-logical-function bitstring-andnot!)) +(define bitstring-or (bitstring-make-logical-function bitstring-or!)) +(define bitstring-xor (bitstring-make-logical-function bitstring-xor!)) + +(define (signed-integer->bitstring len n) + (if (or (>= n (expt 2 (1- len))) (< n (- (expt 2 (1- len))))) + (error 'signed-integer->bitstring + "length ~s too small for signed integer ~s" len n)) + (unsigned-integer->bitstring len (if (negative? n) (+ n (expt 2 len)) n))) + +(define (bitstring->signed-integer b) + (let ((n (bitstring->unsigned-integer b)) + (len (bitstring-length b))) + (cond ((zero? len) 0) + ((bitstring-ref b (1- len)) (- n (expt 2 len))) + (else n)))) + +(define (describe-bitstring b) + (let ((len (bitstring-length b))) + (format #t "a bitstring of length ~s bit~a.~%" len + (if (= len 1) "" "s")))) + +(provide 'bitstring) --- electric-6.05.orig/lib/lisp/apropos.scm +++ electric-6.05/lib/lisp/apropos.scm @@ -0,0 +1,27 @@ +;;; -*-Scheme-*- +;;; +;;; apropos -- print matching symbols + +(define apropos) + +(let ((found)) + +(define (got-one sym) + (if (bound? sym) + (begin + (set! found #t) + (print sym)))) + +(set! apropos (lambda (what) + (if (symbol? what) + (set! what (symbol->string what)) + (if (not (string? what)) + (error 'apropos "string or symbol expected"))) + (set! found #f) + (do ((tail (oblist) (cdr tail))) ((null? tail)) + (do ((l (car tail) (cdr l))) ((null? l)) + (if (substring? what (symbol->string (car l))) + (got-one (car l))))) + (if (not found) + (format #t "~a: nothing appropriate~%" what)) + #v))) --- electric-6.05.orig/lib/lisp/record.scm +++ electric-6.05/lib/lisp/record.scm @@ -0,0 +1,81 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme layer of the record extension. + +(require 'record.o) + +(define (record-field-index name fields) + (let loop ((fields fields) (index 0)) + (cond ((null? fields) + (error 'record-field-index "invalid field name")) + ((eq? name (car fields)) + index) + (else + (loop (cdr fields) (1+ index)))))) + +(define (record-constructor rtd . fields) + + (define (check-fields f) + (if (not (null? f)) + (if (or (not (symbol? (car f))) (memq (car f) (cdr f))) + (error 'record-constructor "invalid field name") + (check-fields (cdr f))))) + + (let* ((rtd-fields (record-type-field-names rtd)) + (indexes '()) + (size (length rtd-fields))) + (if (null? fields) + (set! fields rtd-fields) + (if (not (null? (cdr fields))) + (error 'record-constructor "too many arguments")) + (set! fields (car fields)) + check-fields fields) + (set! indexes + (map (lambda (x) (record-field-index x rtd-fields)) fields)) + (lambda args + (if (not (= (length args) (length fields))) + (error 'record-constructor "invalid number of fields")) + (let ((vec (make-vector size '()))) + (for-each + (lambda (index value) + (vector-set! vec index value)) + indexes args) + (make-record rtd vec))))) + +(define (record-predicate rtd) + (if (not (record-type? rtd)) + (error 'record-predicate "argument not a record-type")) + (lambda (obj) + (and (record? obj) (eq? (record-type-descriptor obj) rtd)))) + +(define (record-accessor rtd field-name) + (let ((index (record-field-index field-name (record-type-field-names rtd)))) + (lambda (obj) + (if (and (record? obj) (eq? (record-type-descriptor obj) rtd)) + (vector-ref (record-values obj) index) + (error 'record-accessor "argument not of correct record type"))))) + +(define (record-modifier rtd field-name) + (let ((index (record-field-index field-name (record-type-field-names rtd)))) + (lambda (obj val) + (if (and (record? obj) (eq? (record-type-descriptor obj) rtd)) + (vector-set! (record-values obj) index val) + (error 'record-modifier "argument not of correct record type"))))) + +(define (describe-record-type rtd) + (format #t "a record type.~%") + (if (null? (record-type-field-names rtd)) + (format #t "It has no fields.~%") + (format #t "Its fields are: ~s.~%" (record-type-field-names rtd)))) + +(define (describe-record rec) + (format #t "a record.~%") + (let ((fields (record-type-field-names (record-type-descriptor rec)))) + (if (null? fields) + (format #t "It has no fields.~%") + (format #t "Its fields are:") + (for-each (lambda (f v) (format #t " (~s ~s)" f v)) + fields (vector->list (record-values rec))) + (format #t ".~%")))) + +(provide 'record) --- electric-6.05.orig/lib/lisp/regexp.scm +++ electric-6.05/lib/lisp/regexp.scm @@ -0,0 +1,23 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme layer of the regexp extension is (almost) empty for now. +;;; It mainly exists to enable use of "(require 'regexp)". + +(require 'regexp.o) + +(define (describe-regexp r) + (format #t "a regular expression.~%") + (format #t "Its pattern is ~s,~%" (regexp-pattern r)) + (format #t "and its flags are ~s.~%" (regexp-flags r))) + +(define (describe-regexp-match m) + (format #t "a regular expression match.~%") + (let ((n (regexp-match-number m))) + (if (zero? n) + (format #t "It has no substring matches.~%") + (format #t "It has ~s substring match~a:~%" n (if (= n 1) "" "es")) + (do ((i 0 (1+ i))) ((= i n)) + (format #t " ~s~%" (cons (regexp-match-start m i) + (regexp-match-end m i))))))) + +(provide 'regexp) --- electric-6.05.orig/lib/lisp/initscheme.scm +++ electric-6.05/lib/lisp/initscheme.scm @@ -0,0 +1,81 @@ +;;; -*-Scheme-*- +;;; +;;; Initialization code for the Elk interpreter kernel. +;;; +;;; This file is loaded on startup before the toplevel (or the file +;;; supplied along with the -l option) is loaded. +;;; +;;; If a garbage collection is triggered while loading this file, +;;; it is regarded as an indication that the heap size is too small +;;; and an error message is printed. + + +;;; Primitives that are part of the core functionality but are not +;;; implemented in C. This is a bad thing, because extension or +;;; application writers should be able to rely on P_Expt(). + +(define (expt x y) + + (define (square x) (* x x)) + + (define (integer-expt b n) + (cond ((= n 0) 1) + ((negative? n) (/ 1 (integer-expt b (abs n)))) + ((even? n) (square (integer-expt b (/ n 2)))) + (else (* b (integer-expt b (- n 1)))))) + + (cond ((zero? x) (if (zero? y) 1 0)) + ((integer? y) (integer-expt x y)) + (else (exp (* (log x) y))))) + + +;;; Synonyms: + +(define call/cc call-with-current-continuation) + + +;;; Backwards compatibility. These procedures are really obsolete; +;;; please do not use them any longer. + +(define (close-port p) + (if (input-port? p) (close-input-port p) (close-output-port p))) + +(define (void? x) (eq? x (string->symbol ""))) + +(define (re-entrant-continuations?) #t) + + +;;; Useful macros (these were loaded by the standard toplevel in +;;; earlier versions of Elk). They shouldn't really be here, but +;;; it's too late... + +(define (expand form) + (if (or (not (pair? form)) (null? form)) + form + (let ((head (expand (car form))) (args (expand (cdr form))) (result)) + (if (and (symbol? head) (bound? head)) + (begin + (set! result (macro-expand (cons head args))) + (if (not (equal? result form)) + (expand result) + result)) + (cons head args))))) + +(define-macro (unwind-protect body . unwind-forms) + `(dynamic-wind + (lambda () #f) + (lambda () ,body) + (lambda () ,@unwind-forms))) + +(define-macro (while test . body) + `(let loop () + (cond (,test ,@body (loop))))) + +(define-macro (when test . body) + `(cond (,test ,@body))) + +(define-macro (unless test . body) + `(when (not ,test) ,@body)) + +(define-macro (multiple-value-bind vars form . body) + `(apply (lambda ,vars ,@body) ,form)) --- electric-6.05.orig/lib/lisp/xlib.scm +++ electric-6.05/lib/lisp/xlib.scm @@ -0,0 +1,429 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme part of the Xlib extension. + +(require 'siteinfo) + +(fluid-let ((load-libraries (string-append site-lib-xlib " " load-libraries))) + (require 'xlib.o)) + +(define (create-window . args) + (apply-with-keywords + 'create-window xlib-create-window + '((parent) (x 0) (y 0) (width) (height) (border 2)) + 'set-window-attributes set-window-attributes-slots args)) + +(define (create-gcontext . args) + (apply-with-keywords + 'create-gcontext xlib-create-gcontext + '((window)) + 'gcontext gcontext-slots args)) + +(define (set-wm-hints! . args) + (apply-with-keywords + 'set-wm-hints! xlib-set-wm-hints! + '((window)) + 'wm-hints wm-hints-slots args)) + +(define (wm-hints w) + (cdr (vector->list (xlib-wm-hints w)))) + +(define (set-wm-normal-hints! . args) + (apply-with-keywords + 'set-wm-normal-hints! xlib-set-wm-normal-hints! + '((window)) + 'size-hints size-hints-slots args)) + +(define (wm-normal-hints w) + (cdr (vector->list (xlib-wm-normal-hints w)))) + +(define (reconfigure-wm-window . args) + (apply-with-keywords + 'reconfigure-wm-window xlib-reconfigure-wm-window + '((window) (screen)) + 'window-configuration window-configuration-slots args)) + + +(define (apply-with-keywords name function formals tag slots args) + (let* ((v (make-vector (1+ (length slots)) '())) + (empty '(empty)) + (l (make-list (1+ (length formals)) empty)) + (slot '())) + (vector-set! v 0 tag) + (do ((a args (cddr a))) ((null? a)) + (if (not (symbol? (car a))) + (error name "even-numbered argument must be a symbol")) + (if (null? (cdr a)) + (error name "missing value for ~s" (car a))) + (set! slot (assq (car a) slots)) + (if slot + (vector-set! v (cdr slot) (cadr a)) + (let loop ((f formals) (g l)) + (if (null? f) + (error name "unknown argument ~s" (car a))) + (if (eq? (car a) (caar f)) + (set-car! g (cadr a)) + (loop (cdr f) (cdr g)))))) + (set-car! (last-pair l) v) + (do ((f formals (cdr f)) (a l (cdr a))) ((null? f)) + (if (eq? (car a) empty) + (if (pair? (cdar f)) + (set-car! a (cadar f)) + (error name "you must specify a value for ~s" (caar f))))) + (apply function l))) + + +;;; Definition of the access and update functions for window attributes, +;;; geometry, gcontexts, etc. + +(define-macro (define-functions definer type fun pref) + (let ((slots (string->symbol (format #f "~s-slots" type)))) + `(for-each eval (map (lambda (s) + (,definer ',type (1+ (length ,slots)) ,fun s ,pref)) ,slots)))) + +(define (define-accessor-with-cache type num-slots fun slot pref) + (let ((name (string->symbol (format #f pref (car slot))))) + `(define (,name object) + (general-accessor object ',type ,fun ,(cdr slot))))) + +(define (define-mutator-with-cache type num-slots fun slot pref) + (let ((name (string->symbol (format #f pref (car slot))))) + `(define (,name object val) + (general-mutator object val ',type ,num-slots ,fun ,(cdr slot))))) + +(define (define-accessor type num-slots fun slot pref) + (let ((name (string->symbol (format #f pref (car slot))))) + `(define (,name . args) + (vector-ref (apply ,fun args) ,(cdr slot))))) + + +(define-functions define-accessor-with-cache + get-window-attributes xlib-get-window-attributes "window-~s") + +(define-functions define-mutator-with-cache + set-window-attributes xlib-change-window-attributes "set-window-~s!") + +(define-functions define-mutator-with-cache + window-configuration xlib-configure-window "set-window-~s!") + +(define-functions define-accessor-with-cache + geometry xlib-get-geometry "drawable-~s") + +(define-functions define-mutator-with-cache + gcontext xlib-change-gcontext "set-gcontext-~s!") + +;; Note: gcontext-clip-mask and gcontext-dashes are bogus. + +(define gcontext-values-slots gcontext-slots) + +(define-functions define-accessor-with-cache + gcontext-values xlib-get-gcontext-values "gcontext-~s") + +(define-functions define-accessor-with-cache + font-info xlib-font-info "font-~s") + +(define-functions define-accessor + char-info xlib-char-info "char-~s") + +(define (min-char-info c) (xlib-char-info c 'min)) +(define (max-char-info c) (xlib-char-info c 'max)) + +;; Note: min-char-attributes, max-char-attributes, and +;; text-extents-attributes are bogus. + +(define-functions define-accessor + char-info min-char-info "min-char-~s") + +(define-functions define-accessor + char-info max-char-info "max-char-~s") + +(define-functions define-accessor + char-info xlib-text-extents "extents-~s") + + +;;; ``cache'' is an a-list of (drawable-or-gcontext-or-font . state) pairs, +;;; where state is a vector of buffers as listed below. Each slot in +;;; a vector can be #f to indicate that the cache is empty. The cache +;;; is manipulated by the ``with'' macro. + +(define cache '()) + +(define num-slots 7) + +(put 'set-window-attributes 'cache-slot 0) +(put 'get-window-attributes 'cache-slot 1) +(put 'window-configuration 'cache-slot 2) +(put 'geometry 'cache-slot 3) +(put 'gcontext 'cache-slot 4) +(put 'font-info 'cache-slot 5) +(put 'gcontext-values 'cache-slot 6) + + +;;; List of buffers that are manipulated by mutator functions and must +;;; be flushed using the associated update function when a ``with'' is +;;; left (e.g., a set-window-attributes buffer is manipulated by +;;; set-window-FOO functions; the buffer is flushed by a call to +;;; (change-window-attributes WINDOW BUFFER)): + +(define mutable-types '(set-window-attributes window-configuration gcontext)) + +(put 'set-window-attributes 'update-function xlib-change-window-attributes) +(put 'window-configuration 'update-function xlib-configure-window) +(put 'gcontext 'update-function xlib-change-gcontext) + + +;;; Some types of buffers in the cache are invalidated when other +;;; buffers are written to. For instance, a get-window-attributes +;;; buffer for a window must be filled again when the window's +;;; set-window-attributes or window-configuration buffers have been +;;; written to. + +(put 'get-window-attributes 'invalidated-by + '(set-window-attributes window-configuration)) +(put 'geometry 'invalidated-by + '(set-window-attributes window-configuration)) +(put 'gcontext-values 'invalidated-by + '(gcontext)) + +;;; Within the scope of a ``with'', the first call to a OBJECT-FOO +;;; function causes the result of the corresponding Xlib function to +;;; be retained in the cache; subsequent calls just read from the cache. +;;; Similarly, calls to Xlib functions for set-OBJECT-FOO! functions are +;;; delayed until exit of the ``with'' body or until a OBJECT-FOO +;;; is called and the cached data for this accessor function has been +;;; invalidated by the call to the mutator function (see ``invalidated-by'' +;;; property above). + +(define-macro (with object . body) + `(if (assq ,object cache) ; if it's already in the cache, just + (begin ,@body) ; execute the body. + (dynamic-wind + (lambda () + (set! cache (cons (cons ,object (make-vector num-slots #f)) cache))) + (lambda () + ,@body) + (lambda () + (for-each (lambda (x) (flush-cache (car cache) x)) mutable-types) + (set! cache (cdr cache)))))) + +;;; If a mutator function has been called on an entry in the cache +;;; of the given type, flush it by calling the right update function. + +(define (flush-cache entry type) + (let* ((slot (get type 'cache-slot)) + (buf (vector-ref (cdr entry) slot))) + (if buf + (begin + ((get type 'update-function) (car entry) buf) + (vector-set! (cdr entry) slot #f))))) + +;;; General accessor function (OBJECT-FOO). See if the data in the +;;; cache have been invalidated. If this is the case, or if the cache +;;; has not yet been filled, fill it. + +(define (general-accessor object type fun slot) + (let ((v) (entry (assq object cache))) + (if entry + (let ((cache-slot (get type 'cache-slot)) + (inval (get type 'invalidated-by))) + (if inval + (let ((must-flush #f)) + (for-each + (lambda (x) + (if (vector-ref (cdr entry) (get x 'cache-slot)) + (set! must-flush #t))) + inval) + (if must-flush + (begin + (for-each (lambda (x) (flush-cache entry x)) inval) + (vector-set! (cdr entry) cache-slot #f))))) + (if (not (vector-ref (cdr entry) cache-slot)) + (vector-set! (cdr entry) cache-slot (fun object))) + (set! v (vector-ref (cdr entry) cache-slot))) + (set! v (fun object))) + (vector-ref v slot))) + + +;;; General mutator function (set-OBJECT-FOO!). If the cache is empty, +;;; put a new buffer of the given type and size into it. Write VAL +;;; into the buffer. + +(define (general-mutator object val type num-slots fun slot) + (let ((entry (assq object cache))) + (if entry + (let ((cache-slot (get type 'cache-slot))) + (if (not (vector-ref (cdr entry) cache-slot)) + (let ((v (make-vector num-slots '()))) + (vector-set! v 0 type) + (vector-set! (cdr entry) cache-slot v) + (vector-set! v slot val)) + (vector-set! (vector-ref (cdr entry) cache-slot) slot val))) + (let ((v (make-vector num-slots '()))) + (vector-set! v 0 type) + (vector-set! v slot val) + (fun object v))))) + + + +(define (translate-text string) + (list->vector (map char->integer (string->list string)))) + +(define (drawable? d) + (or (window? d) (pixmap? d))) + +(define (clear-window w) + (clear-area w 0 0 0 0 #f)) + +(define (raise-window w) + (set-window-stack-mode! w 'above)) + +(define (lower-window w) + (set-window-stack-mode! w 'below)) + +(define (restack-windows l) + (let loop ((w (car l)) (t (cdr l))) + (if t + (begin + (set-window-sibling! (car t) w) + (set-window-stack-mode! (car t) 'below) + (loop (car t) (cdr t)))))) + +(define (define-cursor w c) + (set-window-cursor! w c)) + +(define (undefine-cursor w) + (set-window-cursor! w 'none)) + +(define (create-font-cursor dpy which) + (let ((font (open-font dpy 'cursor))) + (unwind-protect + (create-glyph-cursor font which font (1+ which) + (make-color 0 0 0) (make-color 1 1 1)) + (close-font font)))) + +(define (synchronize d) + (set-after-function! d (lambda (d) (display-wait-output d #f)))) + +(define (font-property font prop) + (let* ((dpy (font-display font)) + (atom (intern-atom dpy prop)) + (properties (vector->list (font-properties font))) + (result (assq atom properties))) + (if result + (cdr result) + result))) + +(define-macro (with-server-grabbed dpy . body) + `(dynamic-wind + (lambda () (grab-server ,dpy)) + (lambda () ,@body) + (lambda () (ungrab-server ,dpy)))) + +(define (warp-pointer dst dst-x dst-y) + (general-warp-pointer (window-display dst) dst dst-x dst-y 'none 0 0 0 0)) + +(define (warp-pointer-relative dpy x-off y-off) + (general-warp-pointer dpy 'none x-off y-off 'none 0 0 0 0)) + +(define (query-best-cursor dpy w h) + (query-best-size dpy w h 'cursor)) + +(define (query-best-tile dpy w h) + (query-best-size dpy w h 'tile)) + +(define (query-best-stipple dpy w h) + (query-best-size dpy w h 'stipple)) + +(define store-buffer) +(define store-bytes) +(define fetch-buffer) +(define fetch-bytes) +(define rotate-buffers) + +(let ((xa-string (make-atom 31)) + (xa-cut-buffers + (vector (make-atom 9) (make-atom 10) (make-atom 11) (make-atom 12) + (make-atom 13) (make-atom 14) (make-atom 15) (make-atom 16)))) + +(set! store-buffer (lambda (dpy bytes buf) + (if (<= 0 buf 7) + (change-property + (display-root-window dpy) + (vector-ref xa-cut-buffers buf) xa-string 8 'replace bytes)))) + +(set! store-bytes (lambda (dpy bytes) + (store-buffer dpy bytes 0))) + +(set! fetch-buffer (lambda (dpy buf) + (if (<= 0 buf 7) + (multiple-value-bind (type format data bytes-left) + (get-property + (display-root-window dpy) + (vector-ref xa-cut-buffers buf) xa-string 0 100000 #f) + (if (and (eq? type xa-string) (< format 32)) data "")) + ""))) + +(set! fetch-bytes (lambda (dpy) + (fetch-buffer dpy 0))) + +(set! rotate-buffers (lambda (dpy delta) + (rotate-properties (display-root-window dpy) xa-cut-buffers delta)))) + + +(define xa-wm-normal-hints (make-atom 40)) + +(define (xlib-wm-normal-hints w) + (xlib-wm-size-hints w xa-wm-normal-hints)) + +(define (xlib-set-wm-normal-hints! w h) + (xlib-set-wm-size-hints! w xa-wm-normal-hints h)) + + +(define xa-wm-name (make-atom 39)) +(define xa-wm-icon-name (make-atom 37)) +(define xa-wm-client-machine (make-atom 36)) + +(define (wm-name w) + (get-text-property w xa-wm-name)) + +(define (wm-icon-name w) + (get-text-property w xa-wm-icon-name)) + +(define (wm-client-machine w) + (get-text-property w xa-wm-client-machine)) + +(define (set-wm-name! w s) + (set-text-property! w s xa-wm-name)) + +(define (set-wm-icon-name! w s) + (set-text-property! w s xa-wm-icon-name)) + +(define (set-wm-client-machine! w s) + (set-text-property! w s xa-wm-client-machine)) + + +;; Backwards compatibility: + +(define display-root-window display-default-root-window) + +(define display-colormap display-default-colormap) + +;; Backwards compatibility hack for old-style make-* functions: + +(define-macro (make-compat make-macro create-function) + `(define-macro (,make-macro . args) + (let ((cargs + (let loop ((a args) (v '())) + (if (null? a) + v + (loop (cdr a) `(',(caar a) ,(cadar a) ,@v)))))) + (cons ,create-function cargs)))) + +(make-compat make-gcontext create-gcontext) +(make-compat make-window create-window) + + +;;; Describe functions go here: + + +(provide 'xlib) --- electric-6.05.orig/lib/lisp/pp.scm +++ electric-6.05/lib/lisp/pp.scm @@ -0,0 +1,117 @@ +;;; -*-Scheme-*- +;;; +;;; Trivial pretty-printer + +(provide 'pp) + +(define pp) + +(let ((max-pos 55) (pos 0) (tab-stop 8)) + + (put 'lambda 'special #t) + (put 'macro 'special #t) + (put 'define 'special #t) + (put 'define-macro 'special #t) + (put 'define-structure 'special #t) + (put 'fluid-let 'special #t) + (put 'let 'special #t) + (put 'let* 'special #t) + (put 'letrec 'special #t) + (put 'case 'special #t) + + (put 'call-with-current-continuation 'long #t) + + (put 'quote 'abbr "'") + (put 'quasiquote 'abbr "`") + (put 'unquote 'abbr ",") + (put 'unquote-splicing 'abbr ",@") + +(set! pp (lambda (x) + (set! pos 0) + (cond ((eq? (type x) 'compound) + (set! x (procedure-lambda x))) + ((eq? (type x) 'macro) + (set! x (macro-body x)))) + (fluid-let ((garbage-collect-notify? #f)) + (pp-object x)) + #v)) + +(define (flat-size s) + (fluid-let ((print-length 50) (print-depth 10)) + (string-length (format #f "~a" s)))) + +(define (pp-object x) + (if (or (null? x) (pair? x)) + (pp-list x) + (if (void? x) + (display "#v") + (write x)) + (set! pos (+ pos (flat-size x))))) + +(define (pp-list x) + (if (and (pair? x) + (symbol? (car x)) + (string? (get (car x) 'abbr)) + (= 2 (length x))) + (let ((abbr (get (car x) 'abbr))) + (display abbr) + (set! pos (+ pos (flat-size abbr))) + (pp-object (cadr x))) + (if (> (flat-size x) (- max-pos pos)) + (pp-list-vertically x) + (pp-list-horizontally x)))) + +(define (pp-list-vertically x) + (maybe-pp-list-vertically #t x)) + +(define (pp-list-horizontally x) + (maybe-pp-list-vertically #f x)) + +(define (maybe-pp-list-vertically vertical? list) + (display "(") + (set! pos (1+ pos)) + (if (null? list) + (begin + (display ")") + (set! pos (1+ pos))) + (let ((pos1 pos)) + (pp-object (car list)) + (if (and vertical? + (or + (and (pair? (car list)) + (not (null? (cdr list)))) + (and (symbol? (car list)) + (get (car list) 'long)))) + (indent-newline (1- pos1))) + (let ((pos2 (1+ pos)) (key (car list))) + (let tail ((flag #f) (l (cdr list))) + (cond ((pair? l) + (if flag + (indent-newline + (if (and (symbol? key) (get key 'special)) + (1+ pos1) + pos2)) + (display " ") + (set! pos (1+ pos))) + (pp-object (car l)) + (tail vertical? (cdr l))) + (else + (cond ((not (null? l)) + (display " . ") + (set! pos (+ pos 3)) + (if flag (indent-newline pos2)) + (pp-object l))) + (display ")") + (set! pos (1+ pos))))))))) + + (define (indent-newline x) + (newline) + (set! pos x) + (let loop ((i x)) + (cond ((>= i tab-stop) + (display "\t") + (loop (- i tab-stop))) + ((> i 0) + (display " ") + (loop (1- i))))))) + --- electric-6.05.orig/lib/lisp/oops.scm +++ electric-6.05/lib/lisp/oops.scm @@ -0,0 +1,274 @@ +;;; -*-Scheme-*- +;;; +;;; A simple `OOPS' package + +(require 'hack.o) + +(provide 'oops) + +(define class-size 5) +(define instance-size 3) + +;;; Classes and instances are represented as vectors. The first +;;; two slots (tag and class-name) are common to classes and instances. + +(define (tag v) (vector-ref v 0)) +(define (set-tag! v t) (vector-set! v 0 t)) + +(define (class-name v) (vector-ref v 1)) +(define (set-class-name! v n) (vector-set! v 1 n)) + +(define (class-instance-vars c) (vector-ref c 2)) +(define (set-class-instance-vars! c v) (vector-set! c 2 v)) + +(define (class-env c) (vector-ref c 3)) +(define (set-class-env! c e) (vector-set! c 3 e)) + +(define (class-super c) (vector-ref c 4)) +(define (set-class-super! c s) (vector-set! c 4 s)) + +(define (instance-env i) (vector-ref i 2)) +(define (set-instance-env! i e) (vector-set! i 2 e)) + +;;; Methods are bound in the class environment. + +(define (method-known? method class) + (eval `(bound? ',method) (class-env class))) + +(define (lookup-method method class) + (eval method (class-env class))) + +(define (class? c) + (and (vector? c) (= (vector-length c) class-size) (eq? (tag c) 'class))) + +(define (check-class sym c) + (if (not (class? c)) + (error sym "argument is not a class"))) + +(define (instance? i) + (and (vector? i) (= (vector-length i) instance-size) + (eq? (tag i) 'instance))) + +(define (check-instance sym i) + (if (not (instance? i)) + (error sym "argument is not an instance"))) + +;;; Evaluate `body' within the scope of instance `i'. + +(define-macro (with-instance i . body) + `(eval '(begin ,@body) (instance-env ,i))) + +;;; Set a variable in an instance. + +(define (instance-set! instance var val) + (eval `(set! ,var ',val) (instance-env instance))) + +;;; Set a class variable when no instance is available. + +(define (class-set! class var val) + (eval `(set! ,var ',val) (class-env class))) + +;;; Convert a class variable spec into a binding suitable for a `let'. + +(define (make-binding var) + (if (symbol? var) + (list var '()) ; No initializer given; use () + var)) ; Initializer has been specified; leave alone + +;;; Check whether the elements of `vars' are either a symbol or +;;; of the form (symbol initializer). + +(define (check-vars vars) + (if (not (null? vars)) + (if (not (or (symbol? (car vars)) + (and (pair? (car vars)) (= (length (car vars)) 2) + (symbol? (caar vars))))) + (error 'define-class "bad variable spec: ~s" (car vars)) + (check-vars (cdr vars))))) + +;;; Check whether the class var spec `v' is already a member of +;;; the list `l'. If this is the case, check whether the initializers +;;; are identical. + +(define (find-matching-var l v) + (cond + ((null? l) #f) + ((eq? (caar l) (car v)) + (if (not (equal? (cdar l) (cdr v))) + (error 'define-class "initializer mismatch: ~s and ~s" + (car l) v) + #t)) + (else (find-matching-var (cdr l) v)))) + +;;; Same as above, but don't check initializer. + +(define (find-var l v) + (cond + ((null? l) #f) + ((eq? (caar l) (car v)) #t) + (else (find-var (cdr l) v)))) + +;;; Create a new list of class var specs by discarding all variables +;;; from `b' that are already a member of `a' (with identical initializers). + +(define (join-vars a b) + (cond + ((null? b) a) + ((find-matching-var a (car b)) (join-vars a (cdr b))) + (else (join-vars (cons (car b) a) (cdr b))))) + +;;; The syntax is as follows: +;;; (define-class class-name . options) +;;; options are: (super-class class-name) +;;; (class-vars . var-specs) +;;; (instance-vars . var-specs) +;;; each var-spec is either a symbol or (symbol initializer). + +(define-macro (define-class name . args) + (let ((class-vars) (instance-vars (list (make-binding 'self))) + (super) (super-class-env)) + (do ((a args (cdr a))) ((null? a)) + (cond + ((not (pair? (car a))) + (error 'define-class "bad argument: ~s" (car a))) + ((eq? (caar a) 'class-vars) + (check-vars (cdar a)) + (set! class-vars (cdar a))) + ((eq? (caar a) 'instance-vars) + (check-vars (cdar a)) + (set! instance-vars (append instance-vars + (map make-binding (cdar a))))) + ((eq? (caar a) 'super-class) + (if (> (length (cdar a)) 1) + (error 'define-class "only one super-class allowed")) + (set! super (cadar a))) + (else + (error 'define-class "bad keyword: ~s" (caar a))))) + (if (not (null? super)) + (let ((class (eval super))) + (set! super-class-env (class-env class)) + (set! instance-vars (join-vars (class-instance-vars class) + instance-vars))) + (set! super-class-env (the-environment))) + `(define ,name + (let ((c (make-vector class-size '()))) + (set-tag! c 'class) + (set-class-name! c ',name) + (set-class-instance-vars! c ',instance-vars) + (set-class-env! c (eval `(let* ,(map make-binding ',class-vars) + (the-environment)) + ,super-class-env)) + (set-class-super! c ',super) + c)))) + +(define-macro (define-method class lambda-list . body) + (if (not (pair? lambda-list)) + (error 'define-method "bad lambda list")) + `(begin + (check-class 'define-method ,class) + (let ((env (class-env ,class)) + (method (car ',lambda-list)) + (args (cdr ',lambda-list)) + (forms ',body)) + (eval `(define ,method (lambda ,args ,@forms)) env) + #v))) + +;;; All arguments of the form (instance-var init-value) are used +;;; to initialize the specified instance variable; then an +;;; initialize-instance message is sent with all remaining +;;; arguments. + +(define-macro (make-instance class . args) + `(begin + (check-class 'make-instance ,class) + (let* ((e (the-environment)) + (i (make-vector instance-size #f)) + (class-env (class-env ,class)) + (instance-vars (class-instance-vars ,class))) + (set-tag! i 'instance) + (set-class-name! i ',class) + (set-instance-env! i (eval `(let* ,instance-vars (the-environment)) + class-env)) + (eval `(set! self ',i) (instance-env i)) + (init-instance ',args ,class i e) + i))) + +(define (init-instance args class instance env) + (let ((other-args)) + (do ((a args (cdr a))) ((null? a)) + (if (and (pair? (car a)) (= (length (car a)) 2) + (find-var (class-instance-vars class) (car a))) + (instance-set! instance (caar a) (eval (cadar a) env)) + (set! other-args (cons (eval (car a) env) other-args)))) + (call-init-methods class instance (reverse! other-args)))) + +;;; Call all initialize-instance methods in super-class to sub-class +;;; order in the environment of `instance' with arguments `args'. + +(define (call-init-methods class instance args) + (let ((called '())) + (let loop ((class class)) + (if (not (null? (class-super class))) + (loop (eval (class-super class)))) + (if (method-known? 'initialize-instance class) + (let ((method (lookup-method 'initialize-instance class))) + (if (not (memq method called)) + (begin + (apply (hack-procedure-environment! + method (instance-env instance)) + args) + (set! called (cons method called))))))))) + +(define (send instance msg . args) + (check-instance 'send instance) + (let ((class (eval (class-name instance)))) + (if (not (method-known? msg class)) + (error 'send "message not understood: ~s" `(,msg ,@args)) + (apply (hack-procedure-environment! (lookup-method msg class) + (instance-env instance)) + args)))) + +;;; If the message is not understood, return #f. Otherwise return +;;; a list of one element, the result of the method. + +(define (send-if-handles instance msg . args) + (check-instance 'send-if-handles instance) + (let ((class (eval (class-name instance)))) + (if (not (method-known? msg class)) + #f + (list (apply (hack-procedure-environment! (lookup-method msg class) + (instance-env instance)) + args))))) + +(define (describe-class c) + (check-class 'describe-class c) + (format #t "Class name: ~s~%" (class-name c)) + (format #t "Superclass: ~s~%" + (if (not (null? (class-super c))) + (class-super c) + 'None)) + (format #t "Instancevars: ") + (do ((v (class-instance-vars c) (cdr v)) (space #f #t)) ((null? v)) + (if space + (format #t " ")) + (print (cons (caar v) (cadar v)))) + (format #t "Classvars/Methods: ") + (define v (car (environment->list (class-env c)))) + (if (not (null? v)) + (do ((f v (cdr f)) (space #f #t)) ((null? f)) + (if space + (format #t " ")) + (print (car f))) + (print 'None)) + #v) + +(define (describe-instance i) + (check-instance 'describe-instance i) + (format #t "Instance of: ~s~%" (class-name i)) + (format #t "Instancevars: ") + (do ((f (car (environment->list (instance-env i))) (cdr f)) + (space #f #t)) ((null? f)) + (if space + (format #t " ")) + (print (car f))) + #v) --- electric-6.05.orig/lib/lisp/build-siteinfo +++ electric-6.05/lib/lisp/build-siteinfo @@ -0,0 +1,67 @@ +. ../config/system +. ../config/site + +if [ _$load_obj = _ld -o _$load_obj = _dl ]; then + force_load_xm="-u ${syms_begin_with}XmIsMotifWMRunning" +fi + +# In HP-UX, the Motif libraries must be linked with xt-motif.o instead +# of placing them into the load-libraries (I don't know why). So just +# flush $libxmotif at this point. + +if [ _$load_obj = _shl ]; then + libxmotif= +fi + +# Take apart $system: + +IFS=- +set $system +machine=$1 +os=$2 +cc=$3 + +# Get version number + +rel=`../util/getversion ../README` +IFS=. +set $rel +major=$1 +minor=$2 +IFS= + +echo Building siteinfo.scm +cat <siteinfo.scm +;;; -*-Scheme-*- +;;; +;;; This file has been produced automatically from the information in +;;; your config/system and config/site files. Do not edit! + + +;;; Miscellaneous parameters from config/system: + +(define site-machine "$machine") +(define site-os "$os") +(define site-cc "$cc") + +(define site-version '($major . $minor)) + + +;;; Various pathnames/options for dynamically loading the X extensions: + +(define site-lib-xlib + "$libxlib") + +(define site-lib-xt + "$libxt") + +(define site-lib-xaw + "$libxaw") + +(define site-lib-xmotif + "$libxmotif") + +(define site-force-load-xm "$force_load_xm") + +(provide 'siteinfo) +EOT --- electric-6.05.orig/lib/lisp/xt.scm +++ electric-6.05/lib/lisp/xt.scm @@ -0,0 +1,48 @@ +;;; -*-Scheme-*- +;;; +;;; The Scheme part of the Xt extension. + +(require 'siteinfo) + +(if (feature? 'motif) + (fluid-let ((load-libraries + (string-append site-force-load-xm " " site-lib-xmotif " " + load-libraries))) + (require 'xt.o 'xt-motif.o)) + (fluid-let ((load-libraries + (string-append site-lib-xt " " load-libraries))) + (require 'xt.o))) + +(load 'xlib.scm) + +(provide 'xlib) +(provide 'xt) + +(define (manage-child w) + (manage-children (list w))) + +(define (unmanage-child w) + (unmanage-children (list w))) + +(define (add-callback w name fun) + (add-callbacks w name (list fun))) + +(define (create-managed-widget . args) + (let ((w (apply create-widget args))) + (manage-child w) + w)) + +(define application-initialize #f) + +(let ((con) (dpy) (app-class #f) (shell-class #f)) + (set! application-initialize + (lambda (name . fallback-res) + (set! con (create-context)) + (if (not (null? fallback-res)) + (apply set-context-fallback-resources! con fallback-res)) + (set! dpy (initialize-display con #f name app-class)) + (create-shell name shell-class (find-class 'application-shell) dpy)))) + +;; Backwards compatibility: + +(define widget-window widget->window) --- electric-6.05.orig/lib/lisp/setf.scm +++ electric-6.05/lib/lisp/setf.scm @@ -0,0 +1,28 @@ +;;; -*-Scheme-*- +;;; +;;; An attempt on defsetf and setf + +(define defsetf) +(define get-setter) + +(let ((setters '())) + + (set! defsetf + (lambda (accessor setter) + (set! setters (cons (cons accessor setter) setters)) + #v)) + + (set! get-setter + (lambda (accessor) + (let ((a (assoc accessor setters))) + (if a + (cdr a) + (error 'get-setter "no setter for ~s" accessor)))))) + +(define-macro (setf var val) + (cond + ((symbol? var) `(set! ,var ,val)) + ((pair? var) + (let ((setter (get-setter (eval (car var))))) + `(,setter ,@(cdr var) ,val))) + (else (error 'setf "symbol or form expected")))) --- electric-6.05.orig/lib/lisp/motif.scm +++ electric-6.05/lib/lisp/motif.scm @@ -0,0 +1,11 @@ +;;; -*-Scheme-*- +;;; +;;; This file is `required' in place of `xwidgets' when the Motif widgets +;;; are to be used. + +(provide 'motif) + +(require 'xwidgets) + +(set! widget-subdirectory 'xm) +(set! load-always '(support)) --- electric-6.05.orig/lib/lisp/recordutil.scm +++ electric-6.05/lib/lisp/recordutil.scm @@ -0,0 +1,41 @@ +;;; -*-Scheme-*- +;;; +;;; Utility macros for use with the record extension. + +(define-macro (define-record-type name fields) + (let* ((rtd (eval `(make-record-type ',name ',fields))) + (namestr (symbol->string name))) + `(begin + (define + ,(string->symbol (string-append namestr "-record")) ,rtd) + (define + ,(string->symbol (string-append "make-" namestr "-record")) + ,(record-constructor rtd '())) + (define + ,(string->symbol (string-append namestr "-record?")) + ,(record-predicate rtd)) #v))) + +(define-macro (define-record-accessors rtd) + (let* ((r (eval rtd))) + `(begin + ,@(map (lambda (field) + `(define ( + ,(string->symbol (string-append (record-type-name r) "-" + (symbol->string field))) + record) + (,(record-accessor r field) record))) + (record-type-field-names r)) #v))) + +(define-macro (define-record-modifiers rtd) + (let* ((r (eval rtd))) + `(begin + ,@(map (lambda (field) + `(define ( + ,(string->symbol (string-append + "set-" (record-type-name r) "-" + (symbol->string field) "!")) + record value) + (,(record-modifier r field) record value))) + (record-type-field-names r)) #v))) + +(provide 'recordutil) --- electric-6.05.orig/lib/lisp/trace.scm +++ electric-6.05/lib/lisp/trace.scm @@ -0,0 +1,48 @@ +;;; -*-Scheme-*- +;;; +;;; A simple trace package contributed in 1990 by WAKITA Ken +;;; (ken-w@is.s.u-tokyo.ac.jp) + +(define trc:trace-list '(())) + +(define (reset-trace) (set! trc:trace-list '(()))) + +(define-macro (trace func) + `(let ((the-func (eval ,func)) + (result #v)) + (if (assoc ',func trc:trace-list) + (error 'trace "~s already trace on." ,func)) + (if (not (compound? ,func)) + (error 'trace "wrong argument type ~s (expected compound)" + (type ,func))) + (set! trc:trace-list + (cons '() + (cons (cons ',func the-func) + (cdr trc:trace-list)))) + (set! ,func + (lambda param-list + (format #t "# Entering ~s~%" + (cons ',func param-list)) + (set! result (apply the-func param-list)) + (format #t "# Exiting ~s ==> ~s~%" + (cons ',func param-list) + result) + result)))) + +(define-macro (untrace func) + `(let ((the-func (assoc ',func trc:trace-list))) + + (define (remove! func) + (let ((prev trc:trace-list) + (here (cdr trc:trace-list))) + (while (and here + (not (eq? func (caar here)))) + (set! prev here) + (set! here (cdr here))) + (if (not here) + (error 'remove "item ~s not found." func) + (set-cdr! prev (cdr here))))) + + (if the-func + (begin (remove! ',func) + (set! ,func (cdr the-func)))))) --- electric-6.05.orig/lib/lisp/gdbmtest.scm +++ electric-6.05/lib/lisp/gdbmtest.scm @@ -0,0 +1,82 @@ +;;; -*-Scheme-*- +;;; +;;; An interactive command loop for testing the GNU gdbm extension. +;;; Contributed by Martin Stut. + + +(require 'gdbm.o) + +(let ((gf (gdbm-open 'test.gdbm 1024 'create)) (last "nothing")) + (if (not gf) + (error 'gdbm-open "cannot open test.gdbm")) + (format #t "Type ? for help~%") + (let loop ((op (read-char))) + (newline) + (if (not (char=? op #\newline)) + (read-string)) ; flush rest of line + (case op + ((#\? #\h) + (format #t "c -- count items~%") + (format #t "d -- delete item~%") + (format #t "f -- fetch item~%") + (format #t "s -- store item~%") + (format #t "n -- next key~%") + (format #t "1 -- first key~%") + (format #t "2 -- next key of last n, 1, or 2~%") + (format #t "r -- reorganize~%") + (format #t "q -- quit~%")) + (#\c + (do ((i 0 (1+ i)) + (x (gdbm-firstkey gf) (gdbm-nextkey gf x))) + ((not x) (format #t "Number of entries: ~s~%" i)))) + (#\d + (display "Key: ") + (if (gdbm-delete gf (read-string)) + (format #t "Deleted.~%") + (format #t "Doesn't exist.~%"))) + (#\f + (display "Key: ") + ((lambda (d) + (if d + (format #t "Data: ~s~%" d) + (format #t "Doesn't exist.~%"))) + (gdbm-fetch gf (read-string)))) + (#\s + (display "Key: ") + ((lambda (k) + (display "Data: ") + (if (= 1 (gdbm-store gf k (read-string) 'insert)) + (format #t "Already there.~%") + (format #t "Inserted.~%"))) + (read-string))) + (#\n + (display "Key: ") + ((lambda (r) + (if r + (begin + (format #t "Next: ~s Data: ~s~%" r (gdbm-fetch gf r)) + (set! last r)) + (print #f))) + (gdbm-nextkey gf (read-string)))) + (#\1 + ((lambda (r) + (if r + (begin + (format #t "First: ~s Data: ~s~%" r (gdbm-fetch gf r)) + (set! last r)) + (print #f))) + (gdbm-firstkey gf))) + (#\2 + ((lambda (r) + (if r + (begin + (format #t "Next: ~s Data: ~s~%" r (gdbm-fetch gf r)) + (set! last r)) + (print #f))) + (gdbm-nextkey gf last))) + (#\r + (gdbm-reorganize gf) + (format #t "Reorganized.~%")) + (#\q + (exit))) + (loop (read-char)))) --- electric-6.05.orig/Makefile.in +++ electric-6.05/Makefile.in @@ -943,14 +943,14 @@ done ) ; install.html: - $(INSTALL) -d -m755 $(prefix)/doc/electric/html + $(INSTALL) -d -m755 $(prefix)/share/doc/electric/html @(cd html/manual ; \ - $(INSTALL) -m644 index.html $(prefix)/doc/electric/html ; \ + $(INSTALL) -m644 index.html $(prefix)/share/doc/electric/html ; \ for d in `$(FIND) . -type d -print`; do \ - $(INSTALL) -d -m755 $(prefix)/doc/electric/html/$$d ; \ + $(INSTALL) -d -m755 $(prefix)/share/doc/electric/html/$$d ; \ (cd $$d ; \ for f in `$(FIND) . -type f -maxdepth 1 -print`; do \ - install -m644 $$f $(prefix)/doc/electric/html/$$d/$$f ; \ + install -m644 $$f $(prefix)/share/doc/electric/html/$$d/$$f ; \ done ) ; \ done ) ; --- electric-6.05.orig/src/include/config.h +++ electric-6.05/src/include/config.h @@ -119,8 +119,8 @@ # define MACFSTAG(x) 0 # define NONFILECH '?' /* character that cannot be in file name */ # define CADRCFILENAME ".cadrc" /* CAD startup file */ -# define LIBDIR "/usr/local/lib/electric/" /* location of library files */ -# define DOCDIR "/usr/local/doc/electric/html/" /* location of HTML files */ +# define LIBDIR "/usr/lib/electric/" /* location of library files */ +# define DOCDIR "/usr/share/doc/electric/html/" /* location of HTML files */ # define ESIMLOC "/usr/local/bin/esim" # define RSIMLOC "/usr/local/bin/rsim" # define PRESIMLOC "/usr/local/bin/presim" --- electric-6.05.orig/debian/TODO +++ electric-6.05/debian/TODO @@ -0,0 +1 @@ +- add icon for electric in the debian menu system --- electric-6.05.orig/debian/control +++ electric-6.05/debian/control @@ -0,0 +1,16 @@ +Source: electric +Section: electronics +Priority: optional +Build-Depends: debhelper, lesstif-dev +Maintainer: Debian QA Group +Standards-Version: 3.5.4 + +Package: electric +Architecture: any +Depends: ${shlibs:Depends} +Description: electrical CAD system + Electric is a sophisticated electrical CAD system that can handle many forms + of circuit design, including custom IC layout (ASICs), schematic drawing, + hardware description language specifications, and electro-mechanical hybrid + layout. + --- electric-6.05.orig/debian/rules +++ electric-6.05/debian/rules @@ -0,0 +1,83 @@ +#!/usr/bin/make -f +# Sample debian/rules that uses debhelper. +# GNU copyright 1997 to 1999 by Joey Hess. + +# Uncomment this to turn on verbose mode. +#export DH_VERBOSE=1 + +# This is the debhelper compatability version to use. +export DH_COMPAT=1 + +build: build-stamp +build-stamp: + dh_testdir + + ./configure --prefix=/usr --mandir=\$${prefix}/share/man --infodir=\$${prefix}/share/info + # Add here commands to compile the package. + $(MAKE) + + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp + + # Add here commands to clean up after the build process. + ./configure --prefix=/usr --mandir=\$${prefix}/share/man --infodir=\$${prefix}/share/info + -$(MAKE) distclean + + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs + + # Add here commands to install the package into debian/tmp. + $(MAKE) install prefix=`pwd`/debian/tmp/usr + $(MAKE) install.html prefix=`pwd`/debian/tmp/usr + + +# Build architecture-independent files here. +binary-indep: build install +# We have nothing to do by default. + +# Build architecture-dependent files here. +binary-arch: build install +# dh_testversion + dh_testdir + dh_testroot +# dh_installdebconf + + # required becuase the original sources are shipped upstream + # with the executable bit set + + chmod 644 $$(cat debian/electric.examples) + + dh_installdocs + dh_installexamples + dh_installmenu +# dh_installemacsen +# dh_installpam +# dh_installinit +# dh_installcron + dh_installmanpages + dh_installinfo + dh_undocumented + dh_installchangelogs ChangeLog + dh_link + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install --- electric-6.05.orig/debian/changelog +++ electric-6.05/debian/changelog @@ -0,0 +1,65 @@ +electric (6.05-2.1) unstable; urgency=low + + * Orphaning this package, setting maintainer to QA. + + -- Kyle McMartin Thu, 17 Mar 2005 11:18:49 -0500 + +electric (6.05-2) unstable; urgency=low + + * New maintainer. (closes: #277731) + + -- Kyle McMartin Fri, 22 Oct 2004 21:22:14 -0400 + +electric (6.05-1) unstable; urgency=low + + * new upstream release + * added menu hints (closes: #128765) + * changed doc-base to go into Technical section per menu-policy + + -- Chris Ruffin Sat, 23 Mar 2002 11:02:56 -0500 + +electric (6.03-3) unstable; urgency=low + + * Upgraded standards conformance to 3.5.4.0 + + -- Chris Ruffin Sun, 3 Jun 2001 22:06:41 -0400 + +electric (6.03-2) unstable; urgency=low + + * Moved documentation to /usr/share/doc (closes: Bug#94788) + + -- Chris Ruffin Thu, 26 Apr 2001 20:32:27 -0400 + +electric (6.03-1) unstable; urgency=low + + * New upstream sources. + + -- Chris Ruffin Mon, 2 Apr 2001 20:44:08 -0400 + +electric (6.02.1-1) unstable; urgency=low + + * New upstrem sources. + * Restructured package + + -- Chris Ruffin Sat, 13 Jan 2001 20:57:44 -0500 + +electric (6.00-2) unstable; urgency=low + + * Added upstream-provided man page + + -- Chris Ruffin Sat, 13 Jan 2001 15:05:06 -0500 + +electric (6.00-1) unstable; urgency=low + + * Initial Release. (closes: Bug#76824, Bug#76825) + * Modified Makefile.in and src/include/config.h to bring package into + into compliance with Debian standards. + * Modified src/usr/usrcomek.c to specify the location of the documentation + directory (/usr/share/doc/electric/html) + + -- Chris Ruffin Sat, 9 Sep 2000 16:50:25 -0400 + +Local variables: +mode: debian-changelog +End: + --- electric-6.05.orig/debian/watch +++ electric-6.05/debian/watch @@ -0,0 +1,5 @@ +# Example watch control file for uscan +# Rename this file to "watch" and then you can run the "uscan" command +# to check for upstream updates and more. +# Site Directory Pattern Version Script +ftp.gnu.org /pub/gnu/electric/ electric-(.*)\.tar\.gz debian uupdate --- electric-6.05.orig/debian/electric.dirs +++ electric-6.05/debian/electric.dirs @@ -0,0 +1 @@ +usr/bin --- electric-6.05.orig/debian/electric.docs +++ electric-6.05/debian/electric.docs @@ -0,0 +1,4 @@ +README +ChangeLog +Electric.xml + --- electric-6.05.orig/debian/electric.menu +++ electric-6.05/debian/electric.menu @@ -0,0 +1,2 @@ +?package(electric):needs=X11 section=Apps/Technical hints="CAD,Electric"\ + title="electric" command="/usr/bin/electric" --- electric-6.05.orig/debian/electric.1 +++ electric-6.05/debian/electric.1 @@ -0,0 +1,286 @@ +.TH electric 1 11/12/00 +.SH NAME +electric - a VLSI design system + +.SH SYNOPSIS +\fBelectric\fR [\fI-m\fR] [\fI-t technology\fR] [\fIlibrary\fR] + +.SH DESCRIPTION +Electric is a general purpose system for all electrical design. +It currently knows about nMOS, CMOS, Bipolar, artwork, +schematics, printed-circuit boards, and many other technologies. +Its has a large set of tools including +multiple design-rule checkers (both incremental and hierarchical), +an electrical rules checker, +over a dozen simulator interfaces, +multiple generators (PLA and pad frame), +multiple routers (stitching, maze, river), +network comparison, +compaction, +compensation, +a VHDL compiler, +and +a silicon compiler that places-and-routes standard cells. +.PP +In addition to the text terminal used to invoke the program, +Electric uses a color display with a mouse as a work station. +Separate windows are used for text and graphics. +.PP +If a \fIlibrary\fR disk file is mentioned on the command line, that +file is read as the initial design for editing. +In addition, the following switches are recognized: +.IP -t +specifies an initial technology. The argument must be a technology name such as +"nmos", "cmos", "mocmos" (MOSIS CMOS), "mocmossub" (MOSIS CMOS Submicron), +"bipolar" (simple Bipolar), +"schematic" (Schematic capture), or "artwork" (sketchpad mode). +.IP -m +specifies there may be multiple monitors and that Electric should look for them. + +.SH REPRESENTATION +Circuits are represented as networks that contain +\fInodes\fR and connecting \fIarcs\fR. +The nodes are electrical components such as transistors, logic gates, and +contacts. +The arcs are simply wires that connect the nodes. +In addition, each node has a set of \fIports\fR which are the sites +of arc connection. +A \fItechnology\fR, then, is simply a set of primitive nodes and arcs +that are the building blocks of circuits designed in that environment. +.PP +Collections of nodes and arcs can also be aggregated into +\fIfacets\fR of \fIcells\fR which can be used higher +in the hierarchy to act as nodes. +These user-defined nodes have ports that come from internal nodes +whose ports are \fIexported\fR. +Facets are collected in \fIlibraries\fR which contain a hierarchically +consistent design. +.PP +Arcs have properties that help constrain the design. +For example, an arc may rotate arbitrarily or be fixed in their angle. +Arcs can also be stretchable or \fIrigid\fR under modification of their +connecting nodes. +These constraints propagate hierarchically from the bottom-up. + +.SH TECHNOLOGIES +A large set of technologies is provided in Electric. +These can be modified with the technology editor, or completely +new technologies can be created. +The following paragraphs describe some of the basic technologies. +.PP +The nMOS technologies have arcs available in Metal, Polysilicon, and Diffusion. +The primitive nodes include normal contacts, +buried contacts, transistors, and "pins" for making arc corners. +Transistors may be serpentine and the pure layer nodes may be polygonally +described with the \fBnode trace\fR command. +The "nmos" technology has the standard Mead&Conway design rules. +.PP +The CMOS technologies have arcs available in Metal, Polysilicon, and Diffusion. +The Diffusion arcs may be found in a P-well implant or in a P+ implant. +Thus, there are two types of metal-to-diffusion contacts, two types +of diffusion pins, and two types of transistors: in P-well and in P+ implant. +As with nMOS, the transistors may be serpentine and the pure layer primitives +may be polygonally defined. +The "cmos" technology has the standard design rules according to Griswold; +the "mocmos" technology has design rules for the MOSIS CMOS process (double metal); +the "mocmossub" technology has design rules for the MOSIS CMOS Submicron process (double poly and up to 6 metal); +the "rcmos" technology has round geometry for the MOSIS CMOS process. +.PP +The "schematic" technology provides basic symbols for doing schematic capture. +It contains the logic symbols: BUFFER, AND, OR, and XOR. +Negating bubbles can be placed by negating a connecting arc. +There are also more complex components such as +flip-flop, off-page-connector, black-box, meter, and power source. +Finally, there are the electrical components: +transistor, resistor, diode, capacitor, and inductor. +Two arc types exist for normal wires and variable-width busses. +.PP +The "artwork" technology is a sketchpad environment for doing +general-purpose graphics. +Components can be placed with arbitrary color and shape. +.PP +The "generic" technology exists for those miscellaneous purposes that do +not fall into the domain of other technologies. +It has the universal arc and pin which can connect to ANY other object +and are therefore useful in mixed-technology designs. +The invisible arc can be used for constraining two nodes without +making a connection. +The unrouted arc can be used for electrical connections that are +to be routed later with real wires. +The facet-center primitive, when placed in a facet, defines +the cursor origin on instances of that facet. + +.SH "DESIGN-RULE CHECKING" +The incremental design-rule checker is normally on and watches all changes +made to the circuit. +It does not correct but prints error messages when design rules are violated. +Hierarchy is not handled, so the contents of subfacets are not checked. +.PP +The hierarchical checker looks all the way down the circuit for all design-rules. +Another option allows an input deck to prepared for ECAD's Dracula +design-rule checker. + +.SH COMPACTION +The compactor attempts to reduce the size of a facet by removing unnecessary +space between elements. +When invoked it will +compact in the vertical and horizontal directions until it can find no way +to compact the facet any further. +It does not do hierarchical compaction, does not guarantee optimal compaction, +nor can it handle non-manhattan geometry properly. +The compactor will also spread out the facet to guarantee no design-rule +violations, if the "spread" option is set. + +.SH SIMULATION +There are many simulator interfaces: +ESIM (the default simulator: switch-level for nMOS without timing), +RSIM (switch-level for MOS with timing), +RNL (switch-level for MOS with timing and LISP front-end), +MOSSIM (switch-level for MOS with timing), +COSMOS (switch-level for MOS with timing), +VERILOG (Cadence simulator), +TEXSIM (a commercial simulator), +SILOS (a commercial simulator), +ABEL (PAL generator/simulator for schematic), and +SPICE (circuit level). +MOSSIM, COSMOS, VERILOG, TEXSIM, SILOS, and ABEL +do not actually simulate: they only write an input deck of your circuit. +.PP +In preparation for most simulators, it is necessary to +export those ports that you wish to manipulate or examine. +You must also export power and ground ports. +.PP +In preparation for SPICE simulation, you must export power and ground signals and. +explicitly connect them to source nodes. +The source should then be parameterized to indicate the amount and whether +it is voltage or current. +For example, to make a 5 volt supply, create a source node and set the SPICE card to: +"DC 5". +Next, all input ports must be exported and connected to the positive side +of sources. +Next, all values that are being plotted must be exported and have meter nodes +placed on them. +The node should have the top and bottom ports connected appropriately. + +.SH "PLA GENERATION" +There are two PLA generators, one specific to nMOS layout, and another +specific to CMOS layout. +The nMOS PLA generator reads a single personality table and generates the +array and all driving circuitry including power and ground connections. +The CMOS PLA generator reads two personality tables (AND and OR) and also +reads a library of PLA helper components (called "pla_mocmos") and generates +the array. + +.SH ROUTING +The router is able to do river routing, maze routing, and simple facet stitching +(the explicit wiring of implicitly connected nodes that abut). +River routing runs a bus of wires between the two opposite sides of a routing channel. +The connections on each side must be in a line so that the bus runs between +two parallel sets of points. +You must use the Unrouted arc from the Generic technology +to indicate the ports to be connected. +The river router can also connect wires to the perpendicular sides of the +routing channel if one or more Unrouted wires cross these sides. +.PP +There are two stitching modes: auto stitching and mimic stitching. +In auto stitching, all ports that physically touch will be stitched. +Mimic stitching watches arcs that are created by the user +and adds similar ones at other places in the facet. + +.SH "NETWORK COMPARISON" +The network maintainer tool is able to compare the networks in the two +facets being displayed on the screen. +Once compared, nodes in one facet can be equated with nodes in the other. +If the two networks are automorphic or otherwise difficult to distinguish, +equivalence information can be specified prior to comparison by selecting +a component in the first facet then selecting a component in the second facet. + +.SH AUTHOR +.nf +Steven M. Rubin + Static Free Software + 4119 Alpine Road + Portola Valley, Ca 94028 + +Also a cast of thousands: + Philip Attfield (Queens University): Polygon merging, facet dates + Ron Bolton (University of Saskatchewan): Miscellaneous help + Mark Brinsmead (Calgary): Apollo porting + Stefano Concina (Schlumberger): Polygon clipping + Peter Gallant (Queen's University): ALS simulation + T. J. Goodman (University of Canterbury) TEXSIM simulation + D. Guptill (Technical University of Nova Scotia): X-window interface + Robert Hon (Columbia University): CIF input + Sundaravarathan Iyengar (Case Western Reserve University): nMOS PLA generator + Allan Jost (Technical University of Nova Scotia): X-window interface + Wallace Kroeker (University of Calgary): Digital filter technology, CMOS PLA generator + Andrew Kostiuk (Queen's University): QUISC 1.0 Silicon compiler + Glen Lawson (S-MOS Systems): GDS-II input + David Lewis (University of Toronto): Short circuit checker + John Mohammed (Schlumberger): Miscellaneous help + Mark Moraes (University of Toronto): X-window interface + Sid Penstone (Queens University): many technologies, GDS-II output, SPICE improvements, SILOS simulation, GENERIC simulation + J. P. Polonovski (Ecole Polytechnique, France): Memory management improvement + Kevin Ryan (Technical University of Nova Scotia): X-window interface + Nora Ryan (Schlumberger): Technology translation, Compaction + Brent Serbin (Queen's University): ALS Simulator + Lyndon Swab (Queen's University): Northern Telecom CMOS technologies + Brian W. Thomson (University of Toronto): Mimic stitcher, RSIM interface + Burnie West (Schlumberger): Network maintainer help, bipolar technology + Telle Whitney (Schlumberger): River router + Rob Winstanley (University of Calgary): CIF input, RNL interface + Russell Wright (Queen's University): Lots of help + David J. Yurach (Queen's University): QUISC 2.0 Silicon compiler +.fi + +.SH "SEE ALSO" +Rubin, Steven M., "A General-Purpose Framework for CAD Algorithms", +\fIIEEE Communications\fR, Special Issue on Communications and VLSI, May 1991. +.br +Rubin, Steven M., \fIComputer Aids for VLSI Design\fR, Addison-Wesley, +Reading, Massachusetts, 1987. +.br +Rubin, Steven M., "An Integrated Aid for Top-Down Electrical Design", +\fIProceedings, VLSI '83\fR (Anceau and Aas, eds.), North Holland, Amsterdam, 1983. +.br +Mead, C. and Conway, L., \fIIntroduction to VLSI Systems\fR, +Addison-Wesley, 1980. +.br +Electrical User's Guide. +.br +Electric Internals manual. + +.SH FILES +.TS +l l. +.cadrc Local startup file +~/.cadrc Personal startup file +.electric.log Session logging file +*.elib Binary input/output files +*.txt Text input/output files +*.cif CIF input/output files +*.pla PLA personality input files +*.map Color map files +*.mac Macro files +*.sim ESIM, RSIM, RNL, and COSMOS simulation output +rsim.in RSIM simulation binary output +rnl.in RNL simulation binary output +*.spi SPICE simulation output +*.ver VERILOG simulation output +*.ntk MOSSIM simulation output +*.sil SILOS simulation output +*.tdl TEXSIM simulation output +*.pal ABLE PAL simulation output + +/usr/local/bin/findfastshorts Fast short circuit checker +/usr/local/bin/fastshorts Slow short circuit checker +/usr/local/bin/esim Switch level simulator: ESIM +/usr/local/bin/rsim Switch level simulator: RSIM +/usr/local/bin/rnl Switch level simulator: RNL +/usr/local/bin/presim RNL and RSIM pre-filter +/usr/local/bin/spice Circuit level simulator: SPICE +/usr/local/electric/lib/nl.l RNL startup file +.TE + + + --- electric-6.05.orig/debian/electric.copyright +++ electric-6.05/debian/electric.copyright @@ -0,0 +1,25 @@ +This package was debianized by Chris Ruffin on +Sat, 9 Sep 2000 16:50:25 -0400. + +It was downloaded from ftp://ftp.gnu.org/pub/gnu/electric/ + +Upstream Author(s): Static Free Software + +Copyright: + +Copyright (c) 2000 Static Free Software + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + --- electric-6.05.orig/debian/electric.examples +++ electric-6.05/debian/electric.examples @@ -0,0 +1,7 @@ +examples/samples.txt +examples/languages/test.scm +examples/languages/test.tcl +examples/pla/cmos-pla-and-table +examples/pla/cmos-pla-or-table +examples/pla/nmos-pla-table + --- electric-6.05.orig/debian/electric.doc-base +++ electric-6.05/debian/electric.doc-base @@ -0,0 +1,11 @@ +Document: electric +Title: Electric Manual +Author: Static Free Software +Abstract: This is the online manual for electric, which gives detailed + information on how to use the electric CAD package to accomplish + many electrical-oriented design tasks. +Section: Technical + +Format: HTML +Index: /usr/share/doc/electric/html/index.html +Files: /usr/share/doc/electric/html/*