''C_SCM'' is the name I gave to a C code generator. * Author: [Sarnold] * License: BSD-like (Tcl's license) 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 ****Work in progress...**** ***Documentation*** defun fname {?type1 arg1...?} return_type body Creates 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. 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. 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} {return-macro {if [not $cond] {$body}}} return-macro arg An alias to [subst -nocommands]. Very useful for macro expansion. ***The source*** ====== #!/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 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 namespace eval cscm { proc body body { return [child-subst [string trim $body \n]] } proc defmacro {name arglist body} { slave eval [list proc ::macros::$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 [slave eval ::macros::$name $args] } # creates the namespace ::macros in the slave interpreter slave eval [list namespace eval ::macros { # return is subst #proc return-macro {var} {uplevel 1 [list subst -nocommands $var]} }] interp alias slave return-macro slave 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 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])" } 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 } 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 # 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 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 $argv ====== ***The example*** ====== include defmacro swap {type a b} { return-macro { with-gensym c { local $type %c = %c $a = $a $b = $b %c } } } # the canonical example defmacro unless {cond body} {return-macro {if [not $cond] {$body}}} defmacro oo {type method args} { append type _$method return-macro { call ${type} $args } } defmacro roll3 {type a b c} { return-macro { swap $type $a $b swap $type $b $c } } 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_to_utf16 a b 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 } ====== ---- !!!!!! %| [Category Language] |% !!!!!!