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 DONECaveats: proc parse could use some error checking. Line numbers would be useful too in error messages.
| Category Compiler |
|---|