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

****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 ?- 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".

***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 [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 $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
        }
        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
}
======

----
!!!!!!
%| [Category Language] |%
!!!!!!