[George Peter Staplin] Dec 6, 2007 - Years ago I created something called coop.  It started out as a C precompiler that added some unique keywords for dealing with single and double linked lists.  I've grown tired of maintaining and porting that compiler, and the lex and yacc code, so I created Coop2 (this time in Tcl).  Oddly Coop2 doesn't yet have any commands for dealing with linked lists.

This Coop2 compiler has some features I wanted to play around with, and it generates C code. 

Here's what coop2 sources can look like:
 structure s
 external function puts
 external function printf
        
 define s -message {char *:msg} { 
        declare int x y
        printf [' "%d\n"] [puts msg]
        printf [' "Hello World"]
 }
 property s int x y

 define s +x {int:value} {
        printf [' "+x %d\n"] [+ [self x] value]
        self x value
 }

 function main {int:argc ; char *[]:argv} {
        declare-object o s
        set o [object s]

        if [>? argc 2] { puts [' "Hello World"] }

        o -message [' "hiya"]
        o +x 123
        o +x 456

        printf [' "%d\n"] argc
        printf [' "size of argv: %d\n"] [sizeof argv]

        puts [' "hello world"]

        o destroy

        return 0
 } int

----
 # Coop2 (a compiler for the Coop2 language)
 # By George Peter Staplin
 
 # This assumes that all pointers are of equal size.
 # People using segmented architectures thus can't use this, but Tcl
 # doesn't run on such systems either AFAIK.
 
 #This is a namespace that is used for providing commands in coop2.
 namespace eval ::coopcore {
     ::variable locals
     ::variable structures
     ::variable methodcount 0
     ::variable external
     
     # This is used to declare variables with a type.
     proc declare {type args} {
 	::variable locals
 	::set code ""
 	::foreach v $args {
 	    ::append code "$type $v;"
 	    ::set locals($v) $type
 	}
 	::return $code
     }
    
     proc declare-object {obj type} {
 	::interp alias {} ::coopcore::$obj {} ::coop::declare-object-eval $obj $type
 	::coop::append-local-cleanup [list rename ::coopcore::$obj {}]
 	::return "void *$obj;"
     }
 
     #This is used to define a method.
     proc define {s name arglist body} {
 	::variable structures
 	::variable structure
 	::variable methodcount
 
 	::coop::cleanup-locals
 
 	::incr methodcount
 	::set argstring [::coop::eval-arglist $arglist]
 	::set method coopmethod$methodcount
 	::coop::code "void * $method (void *self, $argstring) \{"
 	::set structure $s   
 
 	::set i 0
 	::while {"" ne [::set cmd [::coop::parse $body i]]} {
 	    ::coop::code "$cmd;"
 	}
    	::set structure ""
 	::coop::code "return self;"
 	::coop::code "\}"
 	::lappend structures($s) $name
 	::lappend structures($s,types) method
 	::lappend structures($s,methods) [::list $name $method]
     }
 
     proc external {type name} {
 	::variable external
 	::set external($name) $type
 	::interp alias {} ::coopcore::$name {} ::coop::extcall $name
     }
 
     proc function {name arglist body returntype} {
 	::coop::cleanup-locals
 
 	# Evalulate the arglist to setup the locals and arguments. 
 	::set argstring [::coop::eval-arglist $arglist]
 	::coop::code "$returntype $name ($argstring) \{"
 	::set i 0
 	::while {"" ne [::set cmd [::coop::parse $body i]]} {
 	    ::coop::code "$cmd;"
 	}
 	::coop::code "\}"
     }
 
     proc include {name} {
 	::coop::code "\#include $name"
     }
 
 
     proc if {cond body} {
 	::set code "if ($cond) \{\n"
 	::set i 0
 	::while {"" ne [::set cmd [::coop::parse $body i]]} {
 	    ::append code "$cmd;"
 	}
 	::append code "\n\}\n"
 	::return $code
     }
 
     proc structure name {
 	::variable structures
 	# These are some default properties:
 	::set structures($name) [::list _length _references destroy]
 	#The types for the properties above:
 	::set structures($name,types) [::list size_t int method]
 	#The initial method mapping:
 	::lappend structures($name,methods) [::list destroy coopdestroy]
 	::set structures($name,generated) 0
     }
 
     proc set {var value} {
 	::return "$var = $value"
     }
 
     ::foreach op [list + * - / & | && ^ ||] {
 	proc $op {a b} [subst -nocommands -nobackslashes {
 	    ::return "([::set a] $op [::set b])"
 	}]
     }
 
     proc =? {a b} {
 	::return "($a == $b)"
     }
 
     proc <? {a b} {
 	::return "($a < $b)"
     }
 
     proc <=? {a b} {
 	::return "($a <= $b)"
     }
 
     proc >? {a b} {
 	::return "($a > $b)"
     }
 
     proc >=? {a b} {
 	::return "($a >= $b)"
     }
 
     proc !=? {a b} {
 	::return "($a != $b)"
     }
 
     proc ~ operand {
 	::return "~$operand"
     }    
 
     proc ' str {
 	::return "\"[::string map [list "\n" "\\n"] $str]\""
     }
 
     proc sizeof thing {
 	::return "sizeof ($thing)"
     }
 
     proc property {s type args} {
 	::variable structures
 	::foreach i $args {
 	    ::lappend structures($s) $i
 	    ::lappend structures($s,types) $type
 	}
     }
 
     proc return value {
 	::return "return $value"
     }
 
     proc self {args} {
 	::variable structure
 	::return [::coop::dispatch self $structure {*}$args]
     }
 
     proc object {s} {
 	::variable structures
 	::set fun [::coop::object-generator $s]
 	::return "$fun ()"
     }
 }
 
 namespace eval ::coop {
     variable outchan ""
     variable code_head ""
     variable code_body ""
     variable code_tail ""
     variable cell_key_size 8; #The size of the largest type.    
     variable local_cleanup_list [list]
 
 
     variable init_code {
 #include <stdio.h>
 #include <stdlib.h>
 
 	static void *coopobject (size_t s) {
 	    void *p = malloc (s);
 	    if (NULL == p) {
 		perror ("coopobject - malloc");
 		abort ();
 	    }
 	    return p;
 	}
 
 	static void *coopdestroy (void *o) {
 	    /*TODO work with the _references slot to make this automatic. */
 	    free (o);
 	    return NULL;
 	}
     }
 
 
     proc append-local-cleanup {code} {
 	variable local_cleanup_list
 	lappend local_cleanup_list $code
     }
 
     proc cleanup-locals {} {
 	variable local_cleanup_list
 	array unset ::coopcore::locals *
 	foreach i $local_cleanup_list {
 	    uplevel \#0 $i
 	}
     }
 			  
 
     proc code c {
 	variable code_body
 	append code_body "$c\n"
     }
 
     proc code-head c {
 	variable code_head
 	append code_head "$c\n"
     }
 
     proc code-tail c {
 	variable code_tail
 	append code_tail "$c\n"
     }
 
     proc compile {file code} {
 	variable outchan
 	variable init_code
 	variable code_head ""
 	variable code_body ""
 	variable code_tail ""
 
 	set outchan [::open $file w]
 	puts $outchan $init_code
 	#namespace path [list ::coopcore]
 	namespace eval ::coopcore $code
 	#namespace path [list ::coop]
 	puts $outchan $code_head
 	puts $outchan $code_body
 	puts $outchan $code_tail
 	puts "wrote $file"
     }
 
     proc declare-object-eval {obj type args} {
 	dispatch $obj $type {*}$args
     }
 
     proc dispatch {obj objtype args} {
 	variable cell_key_size
 	set code ""
 
 	foreach {msg value} $args {
 	    set offset [lsearch -exact $::coopcore::structures($objtype) $msg]
 	    if {$offset < 0} {
 		return -code error "invalid message: $msg for $structure"
 	    }
 	    set type [lindex $::coopcore::structures($objtype,types) $offset]
 	    incr self_local_count
 	    switch -- $type {
 		method {
 		    set fun coopfun$self_local_count
 		    append code "do \{ void *(*$fun) ();"
 		    append code "$fun = *(void **)(((unsigned char *)$obj) + \
                       [expr {$offset * $cell_key_size}]);"
 		    append code "$fun ($obj"
 		    if {"" ne $value} {
 			append code ", $value"
 		    }
 		    append code "); \} while(0)"
 		}
 
 		default {
 		    set value [string trim $value]
 		    set soffset [expr {$offset * $cell_key_size}]
 		    if {"" eq $value} {
 			append code "(*($type *)(((unsigned char *)$obj) + $soffset))"
 		    } else {
 			set var coopvar$self_local_count
 			append code "do \{"
 		     	append code "$type *$var = (void *)(((unsigned char *)$obj) + $soffset);"
 			append code "*$var = $value;"
 			append code "\} while (0)"
 		    }
 	        }
 	    }
 	}
 	return $code
     }
 
     #This evaluates the arguments to a method or function.
     proc eval-arglist arglist {
 	set args [split $arglist \;]
 	set argstring ""
 	foreach lspec $args {
 	    lassign [split $lspec :] decl var
 	    set decl [string trim $decl]
 	    set var [string trim $var]
 	    #If the type is char *[] or char *[n] move the array part to after the var.
 	    if {[::regexp {(.+)(\[.*\])} $decl all decl ar]} {
 		append var $ar
 	    }	    
 	    set ::coopcore::locals($var) $decl
 	    append argstring "$decl $var,"
 	}
 	if {[string length $argstring]} {
 	    set argstring [string range $argstring 0 end-1]
         }
 	return $argstring
     }
 
     #This is called when an external function is referered to. 
     proc extcall {name args} {
 	if {[llength $args]} {
 	    return "$name ([join $args ,])"
 	} else {
 	    return "$name ($name)"
 	}
     }
 
     proc lookup-method {s key} {
 	foreach mfun $::coopcore::structures($s,methods) {
 	    lassign $mfun m fun
 	    if {$m eq $key} {
 		return $fun
 	    }
 	}
 	return -code error "invalid method: $key"
     }
 
     proc object-generator {s} {
 	set fun coop_${s}_object
 	if {$::coopcore::structures($s,generated)} {
 	    #This object generating function has already been produced.
 	    return $fun
 	}
 	variable cell_key_size
 	variable code_head
 
 	set size [expr {[llength $::coopcore::structures($s)] * $cell_key_size}]
 	set code "static void * $fun (void) \{\n"
 	append code "void *o = coopobject ($size);"
 	set offset 0
 	foreach key $::coopcore::structures($s) type $::coopcore::structures($s,types) {
 	    #::puts "KEY:$key TYPE:$type"
 	    if {"method" eq $type} {
 		set method [lookup-method $s $key]
 		set decl "static void * $method ();"
 		set code_head $decl$code_head
 		append code "\{ void **v = (void **)(((unsigned char *)o) + $offset);"
 		append code "  *v = (void *)$method; \}\n"
 	    } else {
 		append code "\{ $type *v = (void *)(((unsigned char *)o) + $offset);"
 		append code "  *v = 0; \}\n"
 	    }
 	    incr offset $cell_key_size
 	}
 
 	# Initialize the _length to the size of the object.
 	append code "\{ size_t *v = (void *)(((unsigned char *)o));"
 	append code "  *v = $size; \}\n"
 	append code "return o;\n"
 
 	append code "\n\}"
 
 	code-head $code
 
 	set ::coopcore::structures($s,generated) 1
 	return $fun
     }
 
     proc parse {script ivar} {
 	upvar $ivar i
 	set words [list]
 	set word ""
 	set state 0
 	set lastchar ""
 	set bracecount 0
 
 	#This is a little state machine.  It's used to parse function and method bodies.
 
 	for {} {$i < [string length $script]} {incr i} {
 	    set c [string index $script $i]
 	    #puts "C:$c STATE:$state I:$i"
 
 	    if {"QUOTE" eq $state} {
 		if {"\"" eq $c && "\\" ne $lastchar} {
 		    set state 0
 		    lappend words $word
 		    set word ""
 		} else {
 		    append word $c
 		}
 
 	    } elseif {"BLOCK" eq $state} {
 		if {"\}" eq $c && "\\" ne $lastchar} {
 		    incr bracecount -1
 		    if {$bracecount <= 0} {
 			set state 0
 			lappend words $word
 			set word ""
 		    }
 		} elseif {"\{" eq $c && "\\" ne $lastchar} {
 		    incr bracecount
 		} else {
 		    append word $c
 		}
 	    } elseif {"\n" eq $c} {
 		if {[llength $words]} {
 		    if {[string length $word]} {
 			lappend words $word
 		    }
 		    incr i
 		    return [namespace eval ::coopcore $words]
 		}
 	    } elseif {[string is space -strict $c]} {
 		if {[string length $word]} {
 		    lappend words $word
 		    set word ""
 		}
 	    } elseif {"\"" eq $c} {
 		set state QUOTE
 	    } elseif {"\{" eq $c} {
 		set state BLOCK
 		set word ""
 		set bracecount 1
 	    } elseif {"\[" eq $c} {
 		incr i
 		lappend words [::coop::parse $script i]
 	    } elseif {"\]" eq $c} {
 		if {[string length $word]} {
 		    lappend words $word
 		}
 		return [namespace eval ::coopcore $words]
 	    } else {
 		append word $c
 	    }
 	    set lastchar $c
         }	
 	return [namespace eval ::coopcore $words]
     }
 }
 
 if {$argc != 2} {
     puts stderr "syntax is: [info script] output.c input.coop2"
     exit 1
 }
 
 set fd [open [lindex $argv 1] r]
 set code [read $fd]
 close $fd
 coop::compile [lindex $argv 0] $code
 puts DONE

----
Caveats: proc parse could use some error checking.  Line numbers would be useful too in error messages.

----
!!!!!!
%| Category Compiler |%
!!!!!!