''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****


***The source***
======
#!/usr/bin/env tclsh
package require Tcl 8.5;# requires "in/ni" operators

namespace eval tools {
        namespace export lmap assert lpair
        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
        }
}
# 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 {
        
        variable functions
        
        proc body body {
                return "\{[unbody $body]\}"
        }
        proc unbody body {
                return [string trim [child-subst $body] \n]
        }
        
        proc register {name args} {
                variable functions
                set functions($name) $args
        }
        defslave register
                
        proc defun {name arglist ret body} {
                if {$arglist eq ""} {set arglist void} else {
                        set arglist [join [lpair $arglist] ,]
                }
                return "$ret $name ($arglist) [body $body]"
        }
        defslave defun
        
        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 ($c1 ; $c2 ; $c3) [body $body]"
        }
        defslave for _for
        
        proc concat-body {first args} {
                set body [string trim $first \n]
                foreach next $args {
                        append body \n[string trim $next \n]
                }
                set body
        }
        
        proc _do {body while cond {body2 ""}} {
                assert {[string equal $while while]} "while expected in do statement"
                if {$body2 eq ""} {
                        return "do [body $body] while ($cond)"
                }
                return "[unbody $body]\nwhile ($cond) [body [concat-body $body2 $body]]"
        }
        defslave do _do
        
        proc local {type var {val ""}} {
                return "$type $var $val"
        }
        defslave local
        foreach op {/ % | ^ << >> < <= > >= != ==} {
                # gets an operator (binary only)
                proc $op {a b} "return \"(\$a $op \$b)\""
                defslave $op
        }
        
        foreach op {= += -= *= /= %= &= |= ^= <<= >>=} {
                # assignement operators
                proc $op {var value} "return \"\$var $op \$value\""
                defslave $op
        }
        # Exceptions to above operators rules:
        # - can be unary as well as &
        proc - {a {b ""}} {
                if {$b eq ""} {return (-$a)}
                return "($a-$b)"
        }
        defslave -
        
        proc & {a {b ""}} {
                if {$b eq ""} {return (&$a)}
                return "($a&$b)"
        }
        defslave &
        
        # * can be unary or with more than 2 arguments
        proc * {a args} {
                if {[llength $args]==0} {
                        return "(*$a)"
                }
                return "([join $args *])"
        }
        defslave *
        # + can have more than 2 arguments
        proc + {fst args} {
                return "($fst+[join $args +])"
        }
        defslave +
        
        proc _while {clause body} {
                return "while ($clause) [body $body]"
        }
        defslave while _while
        
        proc _if {cond then args} {
                set res "if ($cond) [body $then]"
                foreach {keyw body} $args {
                        switch -- $keyw {
                                else - elseif {
                                        append res " $keyw [body $body]"
                                }
                                default {
                                        error "no such keyword $keyw, else or elseif expected"
                                }
                        }
                }
                set res
        }
        defslave if _if
        
        proc _string a {
                # declares a string litteral
                return \"$a\"
        }
        defslave string _string
        
        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} {
                variable functions
                return "$name ([join $args ,])"
        }
        defslave call
        
        proc include {filename} {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 child-subst body {
                set cmd ""
                set result ""
                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 ""} {
                                        append result [interp eval slave $cmd]
                                        if {[string index $result end] ni {\; \} /}} {
                                                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"
                set result
        }
        
        proc file-treat filename {
                set fd [open $filename]
                set content [read $fd];
                while {![eof $fd]} {append content [read $fd]}
                close $fd
                puts [child-subst $content]
        }
                
        
}



proc main arg {
        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] |%
!!!!!!