''C_SCM'' is the name I gave to a C code generator. 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 gcc -c essai.c Author: [Sarnold] License: BSD-like (Tcl's license) ****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 + - * / % & | ^ << >> += -= 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 body ...? ?"default" body? Standard flow control structure local type varname ?-array n|-arrayconst val|-matrix m n|-matrixconst n val? with-gensym name {type ?-array ...("local" options)?} body Creates a local variable, even after the first lines of the function. with-gensym binds an auto-generated hidden-name variable to $name and sets it in the body. ***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 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 [regsub {(\t*\n)+} [child-subst $body] \n] } proc unbody body { # remove the braces from around the body set body [body $body] return [string trim [string range $body 1 end-1] \n] } 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 "$ret $name ($arglist) \{\n[unbody $::locals]\n$body\n\}" } defslave defun proc with-gensym {var type body} { incr ::autogencounter set varname autogen$::autogencounter eval local [linsert $type 1 $varname] # creates an 'unbody' (embedded code block) # in which the string "$var" is replaced by $varname unbody [string map [list \$$var $varname] $body] } 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} { 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]] } } return $switch\} } 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 [unbody $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" 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 } } if {[llength $args]} { assert {[llength $args]==1} "superfluous arguments for local" register-local "$decl=[lindex $args 0]" return } } register-local $decl return } 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 ""} {append result \n} 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 \n[indent]\} } 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 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 } do { incr x } while [< x 5] {call printf [string "x<5"]} 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] } return 0 } ====== ---- !!!!!! %| [Category Language] |% !!!!!!