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


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

 .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 string
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 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
======

***The example***
======
# 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
}
        

======

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