# tycon.tcl --
#
#	This provides certain key common services to the implementation,
#	notably type and constant manufacturing, but also the root class that
#	knows about things like how to make closures.
#
# Copyright (c) 2014-2015 by Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------

namespace eval ::LLVM {
    # The actual flag values to use in the INT type
    variable INT.type.32bit 0
    variable INT.type.64bit 1

    # The actual flag values to use in the NUMERIC type
    variable NUMERIC.type.int 0
    variable NUMERIC.type.double 1

    # Named structure types need to be only created once
    variable NamedTypeCache {}

    # LLVM::Const --
    #
    #	Create a constant as an LLVM value reference. Note that this does not
    #	do anything to merge constants; that's a service provided directly by
    #	LLVM without our intervention.
    #
    # Parameters:
    #	value -	The value of the constant, which is a Tcl value.
    #	type (optional) -
    #		The type descriptor of the value. If the type is omitted, it
    #		is assumed to be an int32.
    #
    # Results:
    #	The LLVM value reference.

    proc Const {value {type int}} {
	switch -regexp -- $type {
	    "^INT$" {
		return [ConstInt [Type int] $value 0]
	    }
	    {^int\d*$} {
		return [ConstInt [Type $type] $value 0]
	    }
	    "^INT BOOLEAN$" - "^boolean$" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type int] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type int] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "^double$" - "^DOUBLE$" {
		return [ConstReal [Type double] $value]
	    }
	    "^bool$" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type bool] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type bool] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "^STRING$" {
		variable thunkBuilder
		set theObj [$thunkBuilder obj.constant $value]
		return $theObj
	    }
	    default {
		error "constant type not handled: $type"
	    }
	}
    }

    # LLVM::Split --
    #
    #	Divide a string into pieces. Does not assume that separators are
    #	single characters. Handles not splitting braced sub-pieces.
    #
    # Parameters:
    #	string -
    #		The string to split up.
    #	separator (optional) -
    #		The string that separates the parts of the original string.
    #		The string may be a multi-character sequence.
    #
    # Results:
    #	A Tcl list of pieces.

    proc Split {string {separator ,}} {
	set acc ""
	set pieces {}
	set S \u0001
	foreach piece [split [string map [list $separator $S] $string] $S] {
	    append acc $piece
	    if {[regexp -all {\{} $acc] == [regexp -all {\}} $acc]} {
		lappend pieces $acc
		set acc ""
		continue
	    }
	    append acc $separator
	}
	if {$acc ne ""} {error "unbalanced string"}
	return $pieces
    }

    # LLVM::Type --
    #
    #	Create a type as an LLVM type reference.
    #
    # Parameters:
    #	descriptor -
    #		The description of the type.
    #
    # Results:
    #	The LLVM type reference.

    proc Type {descriptor} {
	switch -regexp -matchvar m -- [set t [string trim [string map {\n " "} $descriptor]]] {
	    {^void\s*\*$} {
		# Special case: LLVM doesn't like pointer to void
		return [Type char*]
	    }
	    ^void$ {
		return [VoidType]
	    }
	    ^int$ {
		return [Int32Type]
	    }
	    ^long$ {
		# Machine word
		return [IntType [expr {$::tcl_platform(wordSize) * 8}]]
	    }
	    {^int(\d+)$} {
		return [IntType [lindex $m 1]]
	    }
	    ^STRING$ {
		return [Type named{Tcl_Obj}*]
	    }
	    ^INT$ - ^ENTIER$ - "^INT BOOLEAN$" - "^ZEROONE$" {
		return [Type named{INT,kind:int,i32:int,i64:int64}]
	    }
	    ^NUMERIC$ {
		return [Type named{NUMERIC,kind:int,int:INT,double:DOUBLE}]
	    }
	    ^FOREACH$ {
		return [Type named{ForeachPair,val:int,max:int}]
	    }
	    ^DICTITER$ {
		return [Type "named{DictIter,
			search:Tcl_DictSearch,
			dict:STRING,
			key:STRING,
			value:STRING,
			ref:int,
			done:int1}*"]
	    }
	    ^WIDE$ {
		return [Int64Type]
	    }
	    ^char$ - ^byte$ {
		return [Int8Type]
	    }
	    ^bool$ {
		return [Int1Type]
	    }
	    ^double$ - ^DOUBLE$ {
		return [DoubleType]
	    }
	    ^float$ - ^FLOAT$ {
		return [FloatType]
	    }
	    {^VOID FAIL$} - {^VOID\?$} - {^FAIL$} - {^NEXIST$} -
	    {^NOTHING$} {
		return [Type bool]
	    }
	    {^(.*) FAIL$} - {^FAIL (.*)} - {^(.*)\?$} - {^NEXIST (.*)$} {
		return [Type struct{[Type bool],[Type [lindex $m 1]]}]
	    }
	    {\*$} {
		return [PointerType [Type [string range $t 0 end-1]] 0]
	    }
	    {^LLVMTypeRef_} {
		# In case we get a real LLVM type reference in here
		return $t
	    }
	    {^struct\s*{(.*)}$} {
		set pieces [Split [lindex $m 1]]
		return [StructType [lmap p $pieces {Type $p}] 0]
	    }
	    {^named\s*{(.*)}$} {
		variable NamedTypeCache
		variable NamedFieldIndices
		set pieces [lassign [Split [lindex $m 1]] name]
		set name [string trim $name]
		if {[dict exists $NamedTypeCache $name]} {
		    return [dict get $NamedTypeCache $name]
		}
		set index -1
		set type [NamedStructType $name [lmap p $pieces {
		    incr index
		    if {[regexp {^(\w+):(.+)$} [string trim $p] -> n t]} {
			dict set NamedFieldIndices($name) $n $index
			set p $t
		    }
		    Type $p
		}] 0]
		dict set NamedTypeCache $name $type
		return $type
	    }
	    {^array\s*{(.*)}$} {
		set pieces [Split [lindex $m 1]]
		if {[llength $pieces] != 2} {
		    error "wrong args to array: [join $pieces ,]"
		}
		lassign $pieces type count
		return [ArrayType [Type $type] $count]
	    }
	    {^func\s*{(.*)}$} {
		set pieces [Split [lindex $m 1] <-]
		if {[llength $pieces] != 2} {
		    error "wrong args to func: [join $pieces <-]"
		}
		lassign $pieces ret args
		set pieces [Split $args]
		set va [expr {[string trim [lindex $pieces end]] eq "..."}]
		if {$va} {
		    set pieces [lrange $pieces 0 end-1]
		}
		return [FunctionType [Type $ret] [lmap p $pieces {Type $p}] $va]
	    }
	    default {
		variable NamedTypeCache
		if {[dict exists $NamedTypeCache $t]} {
		    return [dict get $NamedTypeCache $t]
		}
		error "FIXME: unsupported type \"$descriptor\" ($t)"
	    }
	}
    }

    # LLVM::FieldIndex --
    #
    #	Get the index into a named structure for a particular named field.
    #
    # Parameters:
    #	structName -
    #		The name of the structure that contains the field.
    #	fieldName -
    #		The name of the field in the structure.
    #
    # Results:
    #	The index into the field.

    proc FieldIndex {structName fieldName} {
	variable NamedFieldIndices
	if {![info exists NamedFieldIndices($structName)]} {
	    return -code error "no structure called \"$structName\""
	}
	set defs $NamedFieldIndices($structName)
	if {![dict exists $defs $fieldName]} {
	    return -code error \
		"no field called \"$fieldName\" in \"$structName\""
	}
	return [dict get $defs $fieldName]
    }

    # LLVM::timeit --
    #
    #	Reporting wrapper round [time]. This only reports the execution time
    #	if the configuration settings are such that reports are desired.
    #
    # Parameters:
    #	phase -	Short (one or two word) description of what the timed script
    #		is doing.
    #	script -
    #		The script to run that is being instrumented.
    #
    # Results:
    #	None.

    proc timeit {phase script} {
	variable time
	set t [time {uplevel 1 $script}]
	if {$time > 0} {
	    puts "${phase}: [lrange $t 0 1]"
	}
    }

    # Class LLVM::llvmEntity --
    #
    #	Support/root class for classes in the Tcl to LLVM system, providing
    #	selected common services, allowing direct access to parts of the API
    #	such as the llvmtcl package and the constant and type factories.
    #
    # Construction Parameters:
    #	None.
    #
    # Public properties:
    #	None.

    oo::class create llvmEntity {
	constructor {} {
	    namespace path [list {*}[namespace path] ::llvmtcl ::LLVM]
	    #oo::objdefine [self] filter LOG
	}

	# llvmEntity:LOG --
	#
	#	Logging filter that allows detailed tracking of what calls
	#	have been made to a particular class. Not applied by default.
	#
	# Parameters:
	#	N/A (depends on what the filter is wrapping in this call)
	#
	# Results:
	#	N/A (depends on what the wrapped method returns)

	method LOG args {
	    set what [concat "[self] [lindex [self target] 1]" $args]
	    puts stderr ">>$what>>"
	    try {
		return [set v [next {*}$args]]
	    } finally {
		if {[info exists v]} {
		    puts stderr "<<$what<<$v"
		}
	    }
	}

	# llvmEntity:Warn --
	#
	#	How to print a warning message to standard error.
	#
	# Parameters:
	#	msg -	The format string to use to produce the message.
	#	args... -
	#		The arguments to pass into the formatting engine.
	#
	# Results:
	#	None.

	method Warn {msg args} {
	    puts stderr [format "WARNING: $msg" {*}$args]
	}

	# llvmEntity:closure --
	#
	#	Creates a method in the current object that will run the given
	#	script in its "current context", with the currently visible
	#	variables available with their current values. It takes
	#	copies, so it does not support sharing state that way (use an
	#	instance variable if that is desired).
	#
	#	Note that operations like [next] and [self] are not available.
	#
	# Parameters:
	#	name -	The name of the method to create.
	#	arguments -
	#		The formal arguments to the method. These should NOT
	#		be the same as any variables visible in the calling
	#		context.
	#	body -	The script that implements the method.
	#
	# Results:
	#	N/A (depends on what the wrapped method returns)

	method closure {name arguments body} {
	    set vars [lmap v [uplevel 1 info vars] {
		if {[uplevel 1 [list info exist $v]]
		    && ![uplevel 1 [list array exists $v]]} {set v} continue}]
	    oo::objdefine [self] forward $name apply [list \
		[list {*}$vars {*}$arguments] $body \
			[uplevel 1 namespace current]] \
		{*}[lmap v $vars {uplevel 1 [list set $v]}]
	}

	unexport closure
    }
}

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# End:
