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 hope such macros, despite having not much the power that Lisp ones have, 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 + - * / % & | ^ << >> same as above with assignment: += -= ... and or not = . -> incr decr call name ?args...?
Calls function or macro "name" with the given args.
.call obj method ?args? .this method ?args? ->call obj method ?args? ->this method ?args?
Calls a method either with a dot (.) or an arrow (->), specifying an object or calling a method of 'this'.
string tclstring
Transforms the Tcl string into a C one.
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.
static type const type
Prepends the qualifier "static" or "const" to the type.
include headerfile include <sysheaderfile>
Inserts a cpp #include statement.
source filename
Behaves like the Tcl command 'source'.
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".
defmacro name arglist body
Creates a macro. This is a regular Tcl procedure, the only special thing to know is the fact that you should return code as a string. Example:
defmacro unless {cond body} {macro {if [not $cond] {$body}}}
macro stringAn alias to [subst -nocommands]. Very useful for macro expansion.
#!/usr/bin/env tclsh
package require Tcl 8.5;# requires "in/ni" operators
namespace eval tools {
namespace export lmap assert lpair lshift lpop
# functional programming
proc lmap {list cmd} {
set res ""
foreach elt $list {
lappend res [eval $cmd [list $elt]]
}
set res
}
# very useful for args handling
proc lpop {listvar args} {
set len [llength $args]
if {$len == 0} return
upvar 1 $listvar list
set tail [lrange $list end-[expr {$len-1}] end]
set list [lrange $list 0 end-$len]
uplevel 1 [list foreach $args $tail break]
set list
}
# assertions made easy in pure tcl!
proc assert {expr {msg "assertion failed"}} {
if {![uplevel 1 [list expr $expr]]} {error $msg}
}
# assoc value lists like with Scheme
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 current]::$hidden
}
# slave interp
interp create -safe slave
foreach cmd {return break continue while for if string} {
#interp eval slave [list rename $cmd ::macro::$cmd]
interp hide slave $cmd
#interp expose slave $cmd macro_$cmd
#interp rename slave macro_$cmd ::macro::$cmd
}
interp alias {} dput {} puts stderr
# the interpreter dedicated to macro expansion
interp create -safe macro
namespace eval cscm {
# set a stub between the slave interpreter and the master interp
proc set-alias {cmd target args} {
interp alias slave $cmd {} ::cscm::$target {*}$args
}
proc body body {
return [child-subst [string trim $body \n]]
}
proc defmacro {name arglist body} {
macro eval [list proc $name $arglist $body]
interp alias slave $name {} ::cscm::macro-subst $name
return
}
defslave defmacro
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
}
# creates a macro-subst proc in the master interpreter
# it is called with the name of the macro and its arguments
proc macro-subst {name args} {
# expand the code returned by the macro as a string
samebody [macro eval $name $args]
}
# creates the proc macro in the macro interpreter
interp alias macro macro macro subst -nocommands
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
set name autogen$::autogencounter
# creates an 'unbody' (embedded code block)
# in which the string "%var" is replaced by $name
string trim [samebody [string map [list %$var $name] $body]] \n\t
}
defslave with-gensym
proc defconst {name val} {
return "#define [CONST $name] $val"
}
defslave defconst
proc defflag name {return "#define [CONST $name]"}
defslave defflag
proc defcppmacro {name args} {
lpop args body
return "#define [CONST $name]\([join $args {, }]) [string map {\n \\\n} [unbody $body]]"
}
defslave defcppmacro
proc ? {cond then else} {return "[paren1 $cond]?[paren1 $then]:[paren1 $else]"}
# proc to handle #ifdef and #ifndef
# syntax : ifdef ifname name ifbody ?else elsebody?
# ifname : 'ifdef' or 'ifndef'
# two aliases run either ifdef ifdef or ifdef ifndef
# name : the name of the macro constant to test
# ifbody/elsebody : body to handle between #if(n)def .. #else .. #endif
proc ifdef {ifname name ifbody args} {
set res "#$ifname [CONST $name]\n"
append res [unbody $ifbody]
if {[llength $args]==0} {return "$res\n#endif"}
assert {[llength $args]==2} "$ifname const body else body"
if {[lindex $args 0] ne "else"} {error "should be 'else', not '[lindex $args 0]'"}
append res "\n#else\n[unbody [lindex $args 1]]\n#endif"
}
# ifdef
set-alias ifdef ifdef ifdef
# ifndef
set-alias ifndef ifdef ifndef
# CONST: checks whether the argument is capitalized or not
# and emits a warning if it has lowercase letters in it
# because #define should be used on UPPER_CASE macro names
proc CONST name {
if {![regexp {^[A-Z0-9_]+$} $name]} {
dput "warning: macro $name seems not in upper-case letters"
}
}
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]
foreach next $args {
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])"
}
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
}
set-alias and moreop &&
set-alias or moreop ||
# 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 not {a} {return (!$a)}
defslave not
proc _while {clause body} {
return "while [paren1 $clause] [body $body]"
}
defslave while _while
# C++ methods
proc .call {self method args} {return "$self.$method\([join $args {, }])"}
proc ->call {self method args} {return "$self->$method\([join $args {, }])"}
defslave .call
defslave ->call
set-alias .this .call this
set-alias ->this ->call this
# 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
foreach keyword {static const} {
# the keyword is prepended to its arguments
set-alias $keyword idem $keyword
}
foreach statement {break continue} {
set-alias $statement I $statement
}
# 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 _source name {
eval [file-read $name]
}
defslave source _source
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-read filename {
set fd [open $filename]
set content [read $fd];
while {![eof $fd]} {append content [read $fd]}
close $fd
set content
}
}
proc main arg {
set ::indentlevel -1
puts [cscm::unbody [cscm::file-read $arg]]
}
eval main $argv# trymacro.sc
# the canonical macro example
defmacro unless {cond body} {macro {if [not $cond] {$body}}}
defmacro count-for {var range body} {
switch -- [llength $range] {
1 {set range [list 0 $range 1]}
2 {lappend range 1}
3 {}
default {error "invalid syntax for range: $range"}
}
lassign $range start end step
macro {
with-gensym end {
local size_t %end
= %end $end
for [= $var $start] [< $var %end] [+= $var $step] {$body}
}
}
}
defmacro swap {type a b} {
macro {
with-gensym c {
local $type %c
= %c $a
= $a $b
= $b %c
}
}
}
defmacro oo {type method args} {
append type _$method
macro {
call $type $args
}
}
defmacro roll3 {type a b c} {
macro {
swap $type $a $b
swap $type $b $c
}
}
# essai.sc
include <stdio>
source trymacro.sc
ifdef MACRO {
defun essai {int x int y} int {
local int z
unless [< x 0] {= x -x}
# x = abs(x)
while [< x 2] {
call printf [string "%d\n"] x
incr x
}
roll3 int x y z
with-gensym d {
local int* %d
= %d [& x]
}
switch x 1 - 2 {
incr x
} default {
call printf [string "x=%d\n"] x
}
oo g_utf8 convert a b
do {
incr x
} while [< x 5] {call printf [string "x<5\n"]}
return [+ x 1]
}
}
defconst HELLO [string "Hello"]
defflag HELLO_WORLD
defcppmacro HI {a b c} {
if [> [+ a b] c] {
call printf HELLO
}
}
defun main {int argc char** argv} int {
local int i
call printf [string "Arguments (total %d):\n"] argc
count-for i argc {
call printf [string "%d: \[%s\]\n"] [+ i 1] [at argv i]
}
local char str -array 4
local char str2 -arrayconst [string ""]
return 0
}