Check-in [32cf2039c4]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Initial checkin of v0.3
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA1:32cf2039c401d1ecc23e2b1cbcce25a78454aab8
User & Date: neilmadden 2014-12-15 19:52:43
Context
2014-12-15
19:52
Initial checkin of v0.3 Leaf check-in: 32cf2039c4 user: neilmadden tags: trunk
19:44
initial empty check-in check-in: 6b863b4ab2 user: nem tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added library/sicl.tcl.







































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
# sicl.tcl --
# vim: ft=tcl tw=120 sw=4 ts=8 expandtab
#
#       Implements SiCL the "Simple" Command Language. This is basically just
#       a minor repackaging of Tcl with slightly more syntax. I find it
#       pleasing, you may well hate it.
#
# Copyright 2014 Neil Madden.
# License: Tcl-style
#

package require Tcl                 8.6
package require grammar::aycock     1.0

package provide sicl                0.3

namespace eval ::sicl {
    namespace export parse lex eval console
    namespace ensemble create

    namespace import ::grammar::aycock::parser

    proc debug args { }
    #proc debug msg { puts stdout [uplevel 1 [list subst $msg]] }

    variable parser [parser [regsub -all -- {\#[^\n]*\n} {

        # A program is a sequence of commands
        program     ::=     commands                    { _ 0 }
        # Commands are separated by new-lines or semi-colons 
        commands    ::=     command                     { set _ }
        commands    ::=     command NEWLINE commands    { linsert [_ 2] 0 [_ 0] }
        commands    ::=     command SEMICOLON commands  { linsert [_ 2] 0 [_ 0] }
        commands    ::=                                 {}
        # A command is either a comment (ignored) or a sequence of words
        command     ::=     COMMENT                     {}
        command     ::=     words                       { join [_ 0] }
        words       ::=     word                        { set _ }
        words       ::=     word words                  { linsert [_ 1] 0 [_ 0] }

        # A word is one of:
        #   A string, either in double quotes, braces or as a bare word
        #       delimited by whitespace (as in Tcl)
        #   A sub-command: [command] (as in Tcl)
        #   An expression: (...)
        #   A variable substitution: $name / ${name} (as in Tcl, minus arrays)
        #   A script, beginning with ':' and ending with the keyword (gasp)
        #   'end': : ... end
        word        ::=     STRING                      { _ 0 }
        word        ::=     LPAREN expr RPAREN          { _ 1 }
        word        ::=     LBRACK command RBRACK       { join $_ "" }
        word        ::=     VARIABLE                    { _ 0 } 
        word        ::=     COLON block                 { _ 1 }
        # Allow other symbols as literal strings here
        word        ::=     COMMA                       { _ 0 }
        word        ::=     ARROW                       { _ 0 }

        # A block of commands starts with a colon and then either:
        #   - a new-line followed by a series of commands terminated by an END token (---+)
        #   - a single command up to the end of the current line
        block       ::=     NEWLINE commands END        { format {{%s}} [join [_ 1] "; "] }
        block       ::=     command                     { format {{%s}} [_ 0]  }

        expr        ::=     expression                  { _ 0 }
        expr        ::=     dict                        { format {[dict create %s]} [join [_ 0]] }
        expr        ::=     list                        { format {[list %s]} [join [_ 0]] }

        dict        ::=     dictEntries                 { _ 0 }
        list        ::=     listEntries                 { _ 0 }

        dictEntries ::=     dictEntry                   { _ 0 }
        dictEntries ::=     dictEntries COMMA dictEntry { linsert [_ 0] end [_ 2 0] [_ 2 1] }
        dictEntry   ::=     STRING COLON expression     { list [_ 0] [_ 2] }

        listEntries ::=     listEntry                   { set _ }
        listEntries ::=     listEntries COMMA listEntry { linsert [_ 0] end [_ 2] }
        listEntry   ::=     expression                  { _ 0 }

        expression  ::=     STRING                      { expr {[string is alnum [_ 0]] ? [_ 0] 
                                                            : [format {[expr %s]} [join [_ 0] ""]]} }
        expression  ::=     expr ARROW expr             {
            format {[list ::apply [list %s { return %s } [namespace current]]]} [_ 0] [_ 2]
        }
        expression  ::=     factors                     { format {[expr {%s}]} [join [_ 0] ""] }

        factors     ::=     factor factors              { linsert [_ 1] 0 [_ 0] }
        factors     ::=                                 {}

        factor      ::=     STRING                      { _ 0 }
        factor      ::=     COLON                       { _ 0 }
        factor      ::=     STRING LPAREN stuff RPAREN  { join [list [_ 0] [_ 1] [join [_ 2] ""] [_ 3]] "" }
        factor      ::=     VARIABLE                    { _ 0 }
        factor      ::=     LBRACK stuff RBRACK         { join $_ ""}
        factor      ::=     LPAREN expr RPAREN          { _ 1 }

        stuff       ::=     thing stuff                 { linsert [_ 1] 0 [_ 0] }
        stuff       ::=                                 {}
        thing       ::=     STRING                      { _ 0 }
        thing       ::=     LPAREN expression RPAREN    { join $_ "" }
        thing       ::=     LBRACK stuff RBRACK         { join $_ "" }
        thing       ::=     COMMA                       { _ 0 }
        thing       ::=     COLON                       { _ 0 }
        thing       ::=     VARIABLE                    { _ 0 }
        thing       ::=     COMMENT                     { _ 0 }
        thing       ::=     NEWLINE                     { _ 0 }
        thing       ::=     SEMICOLON                   { _ 0 }

    } ""]]

    # Helper procedure for the grammar (dirty hack)
    proc ${parser}::_ args { upvar 1 _ _; lindex $_ {*}$args }


    variable actions [list]
    variable alts   [list]
    proc token {name re} {
        variable actions
        variable alts
        lappend alts $re
        lappend actions "^$re\$" [string map [list TOKEN $name] {
            debug {token -> TOKEN $token}
            lappend types  TOKEN
            lappend values $token
        }]
    }

    proc ignore re {
        variable actions
        variable alts

        lappend alts $re
        lappend actions "^$re\$" { debug {Ignoring $token}; continue }
    }

    ignore              {[ \t\r\f\v]+}
    token NEWLINE       {\n}
    token COMMENT       {\#[^\n]*\n?}
    token LPAREN        {\(}
    token RPAREN        {\)}
    token LBRACK        {\[}
    token RBRACK        {\]}
    token COMMA         {,}
    token COLON         {:}
    token SEMICOLON     {;}
    token ARROW         {->}
    token END           {---+}
    token VARIABLE      {\$(?:(?:[a-zA-Z0-9_]|::)+|\{(?:[^\}\\]|\\.)+\})}
    token STRING        {(?:"(?:[^"\\]|\\.)*"|\{(?:[^\}\\]|\\.)*\}|(?:[^\"\s();,\[\]:$]|:[^\w\s\"\{])+)}

    # Parses a SiCL script into an equivalent Tcl script
    proc parse script {
        variable parser
        lassign [lex $script] types values
        join [$parser parse $types $values] \n
    }

    # Tokenizes a script, returning two list: a list of tokens and a list of
    # values.
    proc lex script {
        variable alts
        variable actions
    
        debug {[join $alts "\n|  "]}

        regsub -all {\\\n} $script {} script
        set tokens [regexp -all -inline [join $alts "|"] $script]

        set types [list]
        set values [list]
        foreach token $tokens {
            debug {Matching token: |$token|}
            switch -regexp -- $token [linsert $actions end default { error "unknown token \"$token\"" }]
        }

        return [list $types $values]
    }

    proc eval script {
        set tcl [parse $script]
        debug {TCL: $tcl}
        uplevel #0 $tcl
    }

    proc console {{in stdin} {out stdout} {prompt "<- "}} {
        while {true} {
            puts -nonewline $out $prompt
            flush $out
            set script ""
            while {[gets $in line] > 0} {
                append script $line\n
            }

            if {[string trim $script] ne ""} {
                try {
                    eval $script
                } on ok result {
                    if {$result ne ""} { puts $out $result }
                } on error msg {
                    puts $out "ERROR: $msg"
                }
            }

            if {[eof $in]} { break }
        }
    }
}

if {[info exists ::argv0] && $::argv0 eq [info script]} {
    sicl console
}