C_SCM is the name I gave to a C code generator.
The goal is to have a full-featured C-preprocessor allowing to write macros. The future macro system will allow defining anonymous variables whose names are auto-generated like in Lisp's macro system (although I do not deeply understand Lisp's macro system). I think such macros, even having no chance to compete with Lisp ones, will allow writing simpler and shorter programs in the C language.
And, writing macros in Tcl, what a fun! :)
Save the following code as c_scm.tcl, save the example as essai.sc and then run the following shell command:
tclsh c_scm.tcl essai.sc >essai.c
defun fname {?type1 arg1...?} return_type bodyCreates a function with arguments, return type and body. Inside fname, the following commands are available:
if while do for switch local call with-gensym + - * / % & | ^ << >> += -= etc. = . -> incr decr if test body ?"elseif" test body...? ?"else" body? while test body for clause1 clause2 clause3 body do body "while" cond ?body? switch value ?caseval ?- caseval ..? body ...? ?"default" body?
Standard flow control structures
local type varname ?-array n|-arrayconst val|-matrix m n|-matrixconst n val?
Creates a local variable following any statement. Variables declarations are automatically put at the start of the function body.
with-gensym name body
Binds an auto-generated variable name to $name and allows to use it in body. That is, "$name" is substitued by this name in the "body".
#!/usr/bin/env tclsh
package require Tcl 8.5;# requires "in/ni" operators
namespace eval tools {
namespace export lmap assert lpair lshift
proc lmap {list cmd} {
set res ""
foreach elt $list {
lappend res [eval $cmd [list $elt]]
}
set res
}
proc assert {expr {msg "assertion failed"}} {
if {![uplevel 1 expr $expr]} {error $msg}
}
proc lpair list {
set res ""
foreach {f s} $list {
lappend res [list $f $s]
}
set res
}
# lshift: shift index 0 of a list and remove it from the original var
proc lshift {var {targetvar ""}} {
upvar $var list
set res [lindex $list 0]
set list [lrange $list 1 end]
if {$targetvar ne ""} {
upvar $targetvar target
set target $res
}
set res
}
}
# gets all tools procs into the global namespace
# notably lmap
namespace import ::tools::*
proc defslave {public {hidden ""}} {
if {$hidden eq ""} {set hidden $public}
interp alias slave $public {} [uplevel namespace curren]::$hidden
}
# slave interp
interp create -safe slave
foreach cmd {return break continue while for if string} {
interp hide slave $cmd
}
interp alias {} dput {} puts stderr
namespace eval cscm {
proc body body {
return [child-subst [string trim $body \n]]
}
proc unbody body {
# remove the braces from around the body
set body [body $body]
string trimright [string trim [string range $body 1 end-1] \n] \t\n
}
proc samebody body {
incr ::indentlevel -1
set res [unbody $body]
incr ::indentlevel
set res
}
proc defun {name arglist ret body} {
set ::locals ""
set ::autogencounter 0
if {$arglist eq ""} {set arglist void} else {
set arglist [join [lpair $arglist] ,]
}
set body [unbody $body]
#dput $::locals
return "\n$ret $name ($arglist) \{\n[unbody $::locals]\n\n$body\n\}"
}
defslave defun
proc with-gensym {var body} {
incr ::autogencounter
uplevel 1 set $var autogen$::autogencounter
# creates an 'unbody' (embedded code block)
# in which the string "$var" is replaced by $varname
string trim [samebody [uplevel 1 [list subst $body]]] \n\t
}
defslave with-gensym
proc at {var index {subindex ""}} {
# index at var[index][subindex]
set res "$var\[$index\]"
if {$subindex ne ""} {append res \[$subindex\]}
set res
}
defslave at
proc _for {c1 c2 c3 body} {
return "for ([dropparen $c1]; [dropparen $c2]; [dropparen $c3]) [body $body]"
}
defslave for _for
proc _switch {var args} {
# indent the body of the switch statement in C
incr ::indentlevel
set switch "switch ($var) \{"
foreach {case body} $args {
if {$case eq "default"} {
append switch "\n[indent]default:"
} else {
append switch "\n[indent]case $case:"
}
if {$body ne "-"} {
append switch \n[unbody [concat-body $body break]]
}
}
incr ::indentlevel -1
return $switch\n[indent]\}
}
defslave switch _switch
proc concat-body {first args} {
set body [string trim $first \ \t\r\n]
dput b,$body
foreach next $args {
dput n,$next
append body \n[string trim $next \ \t\r\n]
}
set body
}
defslave concat-body
proc _do {body while cond {body2 ""}} {
set cond [paren1 $cond]
assert {[string equal $while while]} "while expected in do statement"
if {$body2 eq ""} {
return "do [body $body] while $cond"
}
set res [string trimleft [samebody $body] \t];#the beginning of the result
# should not start by indentation
append res \n[indent]
append res "while $cond [body [concat-body $body2 $body]]"
}
defslave do _do
# brackets for arrays (monodimensional)
proc br {{a ""}} {return \[$a\]}
proc register-local {str} {
append ::locals $str\}\n
}
proc local {type var args} {
# wraps a I command (identity) to pass declaration to unbody
set decl "I \{$type $var"
set result "/* local variable $var declared here */"
if {[llength $args]} {
switch -- [lshift args val] {
-array {
append decl [br [lshift args]]
}
-arrayconst {append decl [br]}
-matrixconst {append decl [br [lshift args]][br]}
-matrix {
append decl [br [lshift args]][br [lshift args]]
}
default {
register-local "$decl=$val"
return $result
}
}
if {[llength $args]} {
assert {[llength $args]==1} "superfluous arguments for local"
register-local "$decl=[lindex $args 0]"
return $result
}
}
register-local $decl
return $result
}
defslave local
proc type {type args} {
switch [llength $args] {
0 {return $type}
1 {return $type[br [lshift args]]}
2 {return $type[br [lshift args]][br [lshift args]]}
default {error "type name ?dim1 ?dim2??"}
}
}
defslave type
proc binop {op args} {
assert {[llength $args]==2} "binary operator $op takes 2 arguments"
return "([join $args $op])"
}
proc set-alias {cmd target args} {
interp alias slave $cmd {} ::cscm::$target {*}$args
}
foreach op {= += -= *= /= %= &= |= ^= <<= >>= < <= > >= != ==} {
# gets an operator (binary only)
set-alias $op binop $op
}
proc moreop {op args} {
assert {[llength $args]>=2} "binary operator $op takes at least 2 arguments"
return "([join $args $op])"
}
foreach op {-> . + / % | ^ << >>} {
# gets an operator (binary only, but many args)
set-alias $op moreop $op
}
# Exceptions to above operators rules:
# - can be unary as well as &
proc unaryop {op a args} {
if {[llength $args]==0} {return ($op$a)}
return "($a$op[join $args $op])"
}
foreach op {- & *} {
set-alias $op unaryop $op
}
proc _while {clause body} {
return "while [paren1 $clause] [body $body]"
}
defslave while _while
# cancel parenthesized expressions
proc dropparen str {
if {[string index $str 0] eq "(" && [string index $str end] eq ")"} {
return [string range $str 1 end-1]
}
return $str
}
proc paren1 str {return ([dropparen $str])}
proc _if {cond then args} {
set res "if [paren1 $cond] [body $then]"
while {[llength $args]} {
switch -- [lshift args] {
else {
append res " else [body [lshift args]]"
}
elseif {
append res " else if [paren1 [lshift args]] [body [lshift args]]"
}
default {
error "no such keyword, else or elseif expected"
}
}
}
set res
}
defslave if _if
proc idem args {set args}
proc I arg {set arg}
defslave I
set-alias break idem break
set-alias continue idem continue
# transform a string
proc escape s {
set s [string map [map-esc {r n t v b a ' \"}] $s]
set res ""
foreach c [split $s ""] {
if {![string is ascii $c]} {
binary scan $c c code
append res \\x$code
} else {append res $c}
}
set res
}
# builds a list suitable for string map
# to transform special chars into their matching escape sequence
proc map-esc list {
foreach escchar $list {
lappend escmap [subst \\$escchar] \\$escchar
}
set escmap
}
proc _string a {
# declares a string litteral
return \"[escape $a]\"
}
defslave string _string
# char declaration
proc char a {return '[escape $a]'}
proc _incr int {return "$int++"}
defslave incr _incr
proc _decr int {return "$int--"}
defslave decr _decr
proc _return arg {
return "return $arg"
}
defslave return _return
proc call {name args} {
return "$name ([join $args ,])"
}
defslave call
proc include {filename} {
if {[string match <*> $filename]} {
return "#include [string range $filename 0 end-1].h>"
}
return "#include \"$filename.h\""
}
defslave include
proc comment {comment} {
return "/* [string map {* _} $comment] */"
}
defslave comment
proc iscomment cmd {
expr {$cmd eq "" || [string index $cmd 0] eq "#"}
}
proc indent {} {string repeat \t $::indentlevel}
proc child-subst body {
set cmd ""
set result \{\n
incr ::indentlevel
foreach line [split $body \n] {
if {[string trim $line " \t"] eq ""} {continue}
if {[regexp {^[ \t]*#.*$} $line]} {
set line [string trimleft $line " \t#"]
append cmd "comment \{[string map {\{ _ \} _} $line]\}"
} else {
append cmd $line
}
if {[info complete $cmd]} {
set cmd [string trimleft $cmd " \t"]
if {$cmd ne ""} {
# eval the command
set text [interp eval slave $cmd]
# concat the text with correct indentation and no parens
append result [indent][dropparen $text]
if {[string index $text end] ni {\; \} /}
&& $text ne "" && [string index $text 0] ne "#"} {
# a statement must end with a ;
append result \;
}
append result \n
set cmd ""
}
} elseif {[string index $cmd end] ne "\\"} {
# we must join command lines iff they end with backslashes
# here we're where we don't have to do that
append cmd \n
}
}
assert {[string equal $cmd ""]} "unfinished command: $cmd"
incr ::indentlevel -1;#restores previous indentation level
append result [indent]\}
set result
}
proc file-treat filename {
set fd [open $filename]
set content [read $fd];
while {![eof $fd]} {append content [read $fd]}
close $fd
puts [unbody $content]
}
}
proc main arg {
set ::indentlevel -1
cscm::file-treat $arg
}
eval main $argvinclude <stdio>
defun essai {int x} int {
if [< x 0] {= x -x}
# x = abs(x)
while [< x 2] {
call printf [string "%d\n"] x
incr x
}
with-gensym my {
local int $my
incr $my
}
switch x 1 - 2 {
incr x
} default {
call printf [string "x=%d\n"] x
}
do {
incr x
} while [< x 5] {call printf [string "x<5\n"]}
return [+ x 1]
}
defun main {int argc char** argv} int {
local int i
call printf [string "Arguments (total %d):\n"] argc
for [= i 0] [< i argc] [incr i] {
call printf [string "%d: \[%s\]\n"] [+ i 1] [at argv i]
}
local char str -array 4
local char str2 -arrayconst [string ""]
return 0
}