#
# makeprims.tcl
# 
# This file is part of the Oxford Oberon-2 compiler
# Copyright (c) 2006 J. M. Spivey
# All rights reserved
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
#    this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright notice,
#    this list of conditions and the following disclaimer in the documentation
#    and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#

# This script scans the files of Oberon code that make up the standard
# library, and extracts the C routines that implement primitives.

puts "/* Generated by makeprims.tcl */"
puts ""
puts "#include \"obx.h\""
puts ""
puts "#define args (bp + HEAD)"


proc make_prim {pname code} {
    puts ""
    puts "PRIMDEF void ${pname}(value *sp) {"
    puts "     value UNUSED *bp = sp;"
    puts "     value UNUSED *cp = bp\[CP\].p;"
    puts "     FPINIT;"
    puts $code
    puts "}"
}

# count -- number of occurrences of a char in a string
proc count {ch s} {return [regsub -all $ch $s "" dummy]}

proc scanfile {fn} {
    set f [open $fn "r"]
    set lnum 0

    while {[gets $f line] >= 0} {
	incr lnum;

	if {[regexp {^PROCEDURE} $line]} {
	    # Read more lines until parentheses are balanced
	    while {[count "\\(" $line] != [count "\\)" $line]} {
		if {[gets $f line2] < 0} break
		incr lnum
		append line " " $line2
	    }
	    regexp {^PROCEDURE.*IS "\*?(.*)"} $line dummy pname
	} elseif {[regexp {^\(\* CODE *(.*)} $line dummy code]} {
	    if {$code != ""} {
		set code "#line $lnum \"$fn\"\n     $code"
	    }

	    while {! [regexp {\*\)} $code]} {
		if {[gets $f line] < 0} {
		    puts stderr "Unterminated chunk in $fn"
		    exit 1
		}

		incr lnum;

		if {$code == ""} {
		    set code "#line $lnum \"$fn\"\n$line"
		} else {
		    set code "$code\n$line"
		}
	    }

	    regsub "\[ \n\]*\\*\\)\[ \t\]*\$" $code "" code

	    make_prim $pname $code
	} elseif {[regexp {^\(\* COPY *(.*)} $line dummy code]} {
	    set code "#line $lnum \"$fn\"\n$code"

	    while {! [regexp {\*\)} $code]} {
		if {[gets $f line] < 0} {
		    puts stderr "Unterminated chunk in $fn"
		    exit 1
		}

		incr lnum
		# regsub "^\[ \t\]*" $line "" line
		set code "$code\n$line"
	    }

	    regsub "\[ \n\]*\\*\\)\[ \t\]*\$" $code "" code
	    puts ""
	    puts $code
	}
    }

    close $f
}

foreach fn $argv {scanfile $fn}
