#	wyrm-cow.dna - Copyright (C) 2003 SM Ryan.  All rights reserved.

package provide wyrmcow @@VER@@

package require wyrmwif
package require wyrmassoc
package require wyrmexpat
package require wyrmsym
package require wyrmdpda
package require wyrmuri

namespace eval ::wyrm {
	namespace export cow

	proc cow args {
		if {[catch {cow::driver $args} rs]} {
			puts $rs\n\n$::errorInfo
			return "report C [list $rs]"
		} else {
			return $rs
		}
	}
	
	namespace eval cow {
		namespace import ::wyrm::*
		
		proc driver argv {
			variable gen
			parser $argv
			sym grammar [namespace current]::cfparser
			cfparser machine: := cf
			vW1
			attributeAnalysis hr
			<Symbol table class definitions>
			switch [hr type:] {
				2 {createLR(k) hr cfparser}
				3 {createDFA hr cfparser}
			}
			if {[hr compiled:]} {
				<Lexical processors>
			}
			<Report the vW1 grammar>
			if {[hr compiled:]} {
				implementParser cfparser
			}
			[hr implementor:]::implementparser $gen
		}
		<Generate compiled parser code>
		<vW2 grammar parser>
		<Grammar properties>
		<DFA parser generation>
		<LR(k) parser generation>
		<Parser automata>
		<Extract vw1 grammar from vw2>
		<Derive the attribute evaluation machine>
	}
	<cow implementations>
}

		

			
variable gen ""
variable depth 0
<Log messages>
<Report errors and information>
<Accumulate generated code>

		

			
variable oldclicks [clock clicks -milliseconds]
proc log {args} {
	variable gen
	variable oldclicks
	set newclicks [clock clicks -milliseconds]
	set wallclock [clock format [clock seconds] -format %H:%M:%S]
	set clicks [expr {$newclicks-$oldclicks}]
	if {$clicks<0} {set clicks [expr {~$clicks}]}
	set elapsed [format %d:%02d:%02d.%03d \
			[expr {$clicks/3600000}] \
			[expr {($clicks/60000)%60}] \
			[expr {($clicks/1000)%60}] \
			[expr {($clicks)%1000}] \
	]
	set message [join $args { }]
	set message $wallclock.$elapsed.$message
	set oldclicks $newclicks
puts $message
	append gen "#.$message\n"
}

		

			
proc report {severity args} {
	variable gen
	variable depth
	set message [join $args { }]
if {[string equal $severity E]} {
	puts "ERROR $message"
} else {
	puts $message
}
	<Generated command: report>
}

		

			
gen report $severity $message

		

			
proc gen {args} {
	variable gen
	variable depth
	if {[llength $args]==1 && [llength [lindex $args 0]] > 1} {set args [lindex $args 0]}
	if {[string equal [lindex $args 0] END]} {
		incr depth -2
		append gen "[string repeat { } $depth]\}\n"
	} else {
		append gen [string repeat { } $depth]
		set begin [string equal [lindex $args 0] BEGIN]
		if {$begin} {set args [lrange $args 1 end]}
		set args [setp op $args]
		append gen $op
		foreach arg $args {append gen " [list $arg]"}
		if {$begin} {append gen " \{"; incr depth 2}
		append gen \n
	}
}

		

report I "vW1 Attribute Grammar"
sym each mn [mr::nonterminals] {
	report I "${mn}:: [string map {, {}} [mr $mn]]"
	catch {report I "  [mr properties: $mn]"}
}
sym each pn [hr::nonterminals] {
	report I "$pn:"
	catch {report I "  [hr properties: $pn]"}
	catch {report I "  shift: [hr action: $pn %shift]"} rs
	sym each alt [hr::if $pn := {}] {
		report I "    $alt"
		catch {
			foreach cs [hr cs: $pn $alt] {
				report I "      [displayAttribute $cs]"
			}
		} rs
		catch {
			report I "      reduce: [hr action: $pn $alt]"
		} rs
	}
	catch {report I "  ::= [hr foreign: $pn]"}
}
sym each sym [hr::terminals] {
	if {![string match *symbol $sym]} continue
	if {[catch {report I "$sym = [hr properties: $sym]"}]} {
		report I "$sym = terminal"
	}
	catch {report I "  shift: [hr action: $sym %shift]"} rs
	catch {report I "  characters: [hr character: $sym]"} rs
	catch {
		foreach cs [hr cs: $sym %shift] {
			report I "  [displayAttribute $cs]"
		}
	} rs
	catch {report I "  ::= [hr foreign: $sym]"}
}

		

			
report I "Lexical Attribute Grammar [symr::if name: := scanner] for [symr::if clients: := unknown]"
sym each pn [symr::nonterminals] {
	report I "$pn:"
	catch {report I "  [symr properties: $pn]"}
	catch {report I "  shift: [hr action: $pn %shift]"} rs
	sym each alt [symr::if $pn := {}] {
		report I "    $alt"
		catch {
			foreach cs [symr cs: $pn $alt] {
				report I "      [displayAttribute $cs]"
			}
		} rs
		catch {
			report I "      reduce: [hr action: $pn $alt]"
		} rs
	}
	catch {report I "  ::= [symr foreign: $pn]"}
}
sym each sym [symr::terminals] {
	if {![string match *symbol $sym]} continue
	if {[catch {report I "$sym = [symr properties: $sym]"}]} {
		report I "$sym = terminal"
	}
	catch {report I "  shift: [hr action: $sym %shift]"} rs
	catch {
		foreach cs [symr cs: $sym %shift] {
			report I "  [displayAttribute $cs]"
		}
	} rs
	catch {report I "  ::= [symr foreign: $sym]"}
}

		

<Literal glyph translation>
<vW2 parser>

		

proc truncate {string} {
	while 1 {
		set i [string first \n $string]
		if {$i==0} {
			set string [string range $string 1 end]
		} else {
			break
		}
	}
	if {$i>0} {incr i -1; set string [string range $string 0 $i]...}
	if {[string length $string]>40} {
		set string [string range $string 0 39]...
	}
	return $string
}

proc parser vw2grammar {
	sym grammar [namespace current]::hr
		hr k: := 2
		hr type: := 3
		hr name: := hyperrules
		hr start: := %start
		hr conflicts: := {}
		hr foreigns: := {}
		hr symtab: := {}
		hr implementor: := ::wyrm::model
	sym grammar [namespace current]::mr
		mr k: := 2
		mr type: := 3
		mr name: := metarules
	sym grammar [namespace current]::rew
	oav bundle [namespace current]::outp
	log Begin parse input.
	<Initialise glyph names before parsing the grammar>
	set grammarhtml {}
	array set header {1 "" 2 "" 3 "" 4 "" 5 "" 6 "" n 0}
	set chunknumber 0
	set ps {}
	set state rule
	set curr %start
	set first 1
	set input ""
	foreach chunk $vw2grammar {
		incr chunknumber
		set token [wyrm::expat::create]
		wyrm::expat::resume $token [
			exec $::env(SHELL) -c {tidy --indent 0 --output-xml 1 --quiet 1; exit 0} << $chunk 2> /dev/null
		]
		set ts 0
		foreach piece [wyrm::expat::end $token] {
			set what [assoc get $piece %what]
			vassoc put piece %chunk $chunknumber
			switch $what {
				start {
					set name [assoc get $piece %name]
					assoc get piece -exact est class c
					switch -glob [lindex $ts end]/$name {
						0/body {
							lappend ts body
						}
						0/* {
							;
						}
						*/cow* {
							lappend ts $name
						}
						{*/h[1-6]} {
							set i [string index $name end]
							set header($i) ""
							set headr(n) $i
							lappend grammarhtml $piece
							lappend ts $name
						}
						default {
							lappend grammarhtml $piece
							lappend ts $name
						}
					}
				}
				end {
					switch -glob [lindex $ts end] {
						0 {
							;
						}
						cow* {
							set ts [lrange $ts 0 end-1]
						}
						{*/h[1-6]} {
							set i [string index $name end]
							set header($i) ""
							set headr(n) [expr {$i-1}]
							lappend grammarhtml $piece
							set ts [lrange $ts 0 end-1]
						}
						default {
							lappend grammarhtml $piece
							set ts [lrange $ts 0 end-1]
						}
					}
				}
				content {
					set data [assoc get piece %data]
					switch -glob [lindex $ts end] {
						0 {
							;
						}
						{*/h[1-6]} {
							set i [string index $name end]
							append header($i) $data
							lappend grammarhtml $piece
						}
						code - cowhn - cowsep {
							setp {ps state input} [dpda $ps $state $input[assoc get piece %data] {
								foreign-chunk
									{((?~code=.*)),((?~N=.*)),<foreigncode>(?~ch=[^][]+)}
									{($code$ch),($N),<foreigncode>}
								skip-newline
									{<(?~state=.*)>[\n\r]}
									{<[incr line; set state]>}
								skip-blanks
									{<(?~state=.*)>[ \t]+}
									{<$state>}
								skip-comments
									{<(?~state=.*)>{[^{}]*}}
									{<$state>}
								end-of-input
									{<rule>$}
									{<quit>}
								start-a-rule
									{<rule>}
									{(rulekind),<notion>}
								
								<Tree rewriting rules>
								<Metarules>
								<Foreign rules>
								<Hyperrules>
								<Property rules>

								unknown-text
									{(.*),(#NS),<rulekind>(?~rest=[^.]*)[.]}
									{<[report E \[$line\] could not identify the text: [truncate $rest]; concat rule]>}
								unknown-rule
									{(.*),((?~N=.*)),<rulekind>(?~rest=[^.]*)[.]}
									{<[report E \[$line\] could not identify the rule: "[truncate [concat $N ## $rest]]"; concat rule]>}
								find-full-stop-at-end-of-rule
									{(.*),<endrule>[.]}
									{<rule>}
								error-at-end-rule
									{(metarule),<endrule>(?~rest=[^.]+)[.]}
									{<[report E \[$curr\] expected '.' to end metarule: [truncate $rest]; concat rule]>}
								error-at-end-rule
									{((?~what=.*)),<endrule>(?~rest=[^.]+)[.]}
									{<[report E \[$curr\] expected '.' to end $what: [truncate $rest]; concat rule]>}
								error-at-end-rule
									{(metarule),<endrule>(?~rest=.*)}
									{<[report E \[$curr\] expected '.' to end metarule: [truncate $rest]; concat quit]>}
								error-at-end-rule
									{((?~what=.*)),<endrule>(?~rest=.*)}
									{<[report E \[$curr\] expected '.' to end $what: [truncate $rest]; concat quit]>}
									
								<Parse the next hypernotion, metanotion, or symbol>

								skip-comments
									{<(?~state=.*)>\{[^{}]*\}}
									{<$state>}
							}]
						}
						default {
							lappend grammarhtml $piece
						}
					}
				}
			}
		}
	}
	<Ensure foreign and hyperrules are disjoint>
	<Symbol table postparse processing>
	<Make aleph definitions of undefined attributes>
	log Complete parse input.
	foreach {character name} [array get glyphName] {
		hr glyph: $name := $character
	}
}

		

identify-a-property-rule
	{(proto),((?~N=.*)),<rulekind>=}
	{($N),<propertyrule>}

<Attribute property rule>
<Conflicts property rule>
<Glyph property rule>
<Grammar type property rule>
<Implementor property rule>
<Include property rule>
<Lookahead property rule>
<Name property rule>
<Reserved symbol property rule>
<Signature property rule>
<Start property rule>
<Stylesheet property rule>
<Symbol table>

unidentified-property
	{((?~P=.*)),<propertyrule>[^.]*}
	{(property),<[report E \[$line\] unknown property: $P; concat endrule]>}

		

start-property
	{(start),<propertyrule>}
	{(startproperty),<notion>}
start-property
	{((proto|meta|hyper)),((?~N=.*)),<startproperty>}
	{(start property),<[set first 0; hr %start := $N,%end; concat endrule]>}

		

k-property
	{(k),<propertyrule>}
	{(),<kproperty>}
k-property
	{((?~K=.*)),<kproperty>(?~k=\d+)}
	{($K$k),<kproperty>}
k-property
	{((?~K=.*)),<kproperty>}
	{(k property),<[hr k: := $K; concat endrule]>}

		

name-property
	{(name),<propertyrule>}
	{(nameproperty),<notion>}
name-property
	{((proto|meta|hyper)),((?~N=.*)),<nameproperty>}
	{(name property),<[hr name: := $N; mr name: := $N_metarules; concat endrule]>}

		

grammar-type-property
	{(type),<propertyrule>}
	{(),<typeproperty>}
grammar-type-property
	{((?~K=.*)),<typeproperty>(?~k=\d+)}
	{($K$k),<typeproperty>}
grammar-type-property
	{((?~K=2|3)),<typeproperty>}
	{(type property),<[hr type: := $K; concat endrule]>}
grammar-type-property
	{((?~K=.*)),<typeproperty>}
	{(type property),<[report E \[$line\] grammar type not 2 or 3: $K; concat endrule]>}

		

include-property
	{(include),<propertyrule>'(?~uri=([^']|'')*)'}
	{($uri),(),<endincludeuri>}
end-include-property
	{((?~garbage=.*)),<endincludeuri>(?~text=[^.])}
	{($garbage$text),<endincludeuri>}	
end-include-property
	{((?~uri=.*)),((?~garbage=.*)),<endincludeuri>[.]}
	{<rule>[
		if {[string length $garbage]} {report E unexpected text after include uri: [truncate $garbage]}
		uri get [string map {'' '} $uri]
	]}

include-property
	{(include),<propertyrule>\[}
	{(%include),(),(1),<foreigncode>}
included-foreign-text
	{(%include),((?~code=.*)),(1),<foreigncode>\]}
	{(include property),<[
		gen foreign_include $code
		concat endrule
	]>}

include-property
	{(include),<propertyrule>}
	{(include property),<[
		report E \[$line\] url or foreign code expected after include
		concat endrule
	]>}

		

implementor-property
	{(implementor),<propertyrule>'(?~N=([^']|'')+)'}
	{(implementor property),<[hr implementor: := [string map {'' '} $N]; concat endrule]>}

		

identify-a-metarule
	{(meta),((?~N=.*)),<rulekind>:\s*:}
	{($N),<[set curr $N; concat metarule]>}
identify-a-bad-metarule
	{(hyper|proto),(#NS),<rulekind>:\s*:[^.]*}
	{(metarule),<[
		report E \[$line\] missing metanotion before '::'
		concat endrule
	]>}
metarule
	{<metarule>}
	{(),(mrmember)<notion>}
metarule-member
	{((?~rule=.*)),((proto|meta|hyper)),((?~HN=.*)),<mrmember>}
	{([sym union $rule $HN]),<mrmemberseparator>}
metarule-alternative
	{<mrmemberseparator>[;|]}
	{(mrmember),<notion>}
metarule-completed
	{((?~MN=.*)),((?~rule=.*)),<mrmemberseparator>}
	{(metarule),<[mr $MN +:= $rule; concat endrule]>}

		

identify-a-bad-hyperrule
	{(hyper|proto),(#NS),<rulekind>:\s*[^.]*}
	{(hyperrule),<[
		report E \[$line\] missing hypernotion before ':'
		concat endrule
	]>}
identify-a-hyperrule
	{((proto|meta|hyper)),((?~N=.*)),<rulekind>:}
	{($N),<[set curr $N; concat hyperrule]>}
hyperrule
	{<hyperrule>}
	{(),(),(hrmember)<notion>}
hyperrule-equal-member
	{((proto|meta|hyper)),((?~HN=.*)),<hrmember>=\s*=}
	{($HN%eq%),(hrposteqmember),<notion>}
hyperrule-equal-member
	{((proto|meta|hyper)),((?~HN=.*)),<hrmember>=}
	{($HN%eq%),(hrposteqmember),<notion>}
hyperrule-not-equal-member
	{((proto|meta|hyper)),((?~HN=.*)),<hrmember>/\s*=}
	{($HN%ne%),(hrposteqmember),<notion>}
hyperrule-not-equal-member
	{((proto|meta|hyper)),((?~HN=.*)),<hrmember>­}
	{($HN%ne%),(hrposteqmember),<notion>}
hyperrule-post-equal-member
	{((?~HN1=.*)),((proto|meta|hyper)),((?~HN2=.*)),<hrposteqmember>}
	{(hyper),($HN1$HN2),<hrmember>}
hyperrule-member
	{((?~alternative=.*)),((proto|meta|hyper)),((?~HN=.*)),<hrmember>}
	{([
		if {[sym null $alternative]} {set HN} else {sym concat $alternative $HN}
	]),<hrmemberseparator>}
hyperrule-member
	{<hrmemberseparator>,}
	{(hrmember),<notion>}
hyperrule-alternative
	{((?~rule=.*)),((?~alternative=.*)),<hrmemberseparator>[;|]}
	{([sym union $rule $alternative]),(),(hrmember),<notion>}
hyperrule-completed
	{((?~HN=[^%].*)),((?~rule=.*)),((?~alternative=.*)),<hrmemberseparator>}
	{([if {[string match *symbol $HN]} {concat symbol rule} else {concat hyperrule}]),<[
		hr $HN +:= [sym union $rule $alternative]
		if {$first && ![string match *symbol $HN]} {hr %start := $HN,%end; set first 0}
		concat endrule
	]>}

		

start-a-protonotion
	{<notion>(?~N=[a-z()]+)}
	{(proto),($N),<notioni>}
start-a-protonotion
	{<notion>(?~N=[#'])}
	{(proto),(),<notioni>$N}
start-a-hypernotion
	{<notion>(?~N=\[)}
	{(hyper),(),<notioni>$N}
start-a-metanotion
	{<notion>(?~N=[A-Z0-9]+)}
	{(meta),($N),<notioni>}
empty-notion
	{((?~state=.*)),<notion>}
	{(proto),(#NS),<$state>}
<Literal glyphs in a hypernotion>
<Decimal numbers in a hypernotion>
continue-a-protonotion
	{(proto),((?~PN=.*)),<notioni>(?~N=[a-z()]+)}
	{(proto),($PN$N),<notioni>}
continue-a-metanotion
	{(meta),((?~MN=.*)),<notioni>(?~N=[A-Z0-9]+)}
	{(meta),($MN$N),<notioni>}
continue-a-hypernotion
	{(.*),((?~HN=.*)),<notioni>(?~N=[a-z()A-Z0-9]+)}
	{(hyper),($HN$N),<notioni>}
end-a-notion
	{((?~state=.*)),((?~kind=.*)),((?~N=.*)),<notioni>}
	{($kind),([sym encode string $N]),<$state>}

		

variable defaultGlyphName
array set defaultGlyphName {
	<Default glyph translations>
}

		

\n newline		\r return		\t tab
" " space		! exclaim		"\"" quote		# hash
$ dollar		% percent		& ampersand		'' apostrophe
( leftparen		) rightparen	* asterisk		+ plus
, comma			- dash			. fullstop		/ slash
0 zero			1 one			2 two			3 three
4 four			5 five			6 six			7 seven
8 eight			9 nine			: colon			; semicolon
< lessthan		= equals		> greaterthan	? query
@ at			A largea		B largeb		C largec
D larged		E largee		F largef		G largeg
H largeh		I largei		J largej		K largek
L largel		M largem		N largen		O largeo
P largep		Q largeq		R larger		S larges
T larget		U largeu		V largev		W largew
X largex		Y largey		Z largez		[ leftbracket
\\ backslash	] rightbracket	^ circumflex	_ underline
@ at			a lettera		b letterb		c letterc
d letterd		e lettere		f letterf		g letterg
h letterh		i letteri		j letterj		k letterk
l letterl		m letterm		n lettern		o lettero
p letterp		q letterq		r letterr		s letters
t lettert		u letteru		v letterv		w letterw
x letterx		y lettery		z letterz		\{ leftbrace
| verticalbar	\} rightbrace	~ tilde

		

variable defaultGlyphName
array set glyphName [array get defaultGlyphName]

		

glyph-property
	{(glyph),<propertyrule>'(?~char=''|[^'])'}
	{($char),(glyphproperty),<notion>}
glyph-property
	{(glyph),<propertyrule>}
	{<[report E \[$line\] missing literal after 'glyph=' property; concat quit]>}
glyph-property
	{(.*),(proto),(#NS),<glyphproperty>}
	{(glyph property),<[report E \[$line\] missing glyphname; concat endrule]>}
glyph-property
	{((?~char=.*)),(proto),((?~N=.*)),<glyphproperty>}
	{(glyph property),<[set glyphName($char) $N; concat endrule]>}

		

literal-glyphs
	{<notioni>'(?~string=([^']|'')*)'}
	{<notioni>[string map [array get glyphName] $string]}
literal-glyphs-error
	{<notioni>'}
	{<[report E \[$curr\] missing close quote ('); concat notioni]>}

		

NUMBER
	{<notioni>#(?~num=[0-9 \t\n]+)}
	{<notioni>number([string map {
		0 zero 1 one 2 two 3 three 4 four
		5 five 6 six 7 seven 8 eight 9 nine
		" " "" "\t" "" "\n" ""
	} $num])}
missing-NUMBER
	{<notioni>#}
	{<[report E \[$curr\] missing digits after "'#'"; concat notioni]>}

		

identify-a-foreign-rule
	{((proto|meta|hyper)),((?~HN=.*)),<rulekind>:\s*(?~la=(\([A-Z0-9 \t\n]*\))?[A-Z0-9 \t\n]*[a-z() \t\n]*\[)}
	{($HN),(),<[set curr $N; concat foreignrule]>$la}
foreign-text-variables
	{<foreignrule>(\((?~output=([A-Z0-9 \t\n]*))\))?(?~input=[A-Z0-9 \t\n]*)(?~language=[a-z() \t\n]*)}
	{([regsub -all \\s+ $output {}]),([regsub -all \\s+ $input {}]),([regsub -all \\s+ $language {}]),(),(0),<foreigncode>}
foreign-code-begin
	{(0)<foreigncode>\[}
	{(1)<foreigncode>}
foreign-code-begin
	{((?~HN=.*)),((?~alts=.*)),((?~output=.*)),((?~input=.*)),((language=.*)),((?~code=.*)),(0),<foreigncode>}
	{(foreign rule),<[report E missing foreign-code '\[...\]': $HN; concat endrule]>}
foreign-code-end
	{((?~alts=.*)),((?~output=.*)),((?~input=.*)),((language=[^%]*)),((?~code=.*)),(1),<foreigncode>\]}
	{([
		if {![string length $output]} {set output -}
		if {![string length $input]} {set input -}
		if {![string length $language]} {set language -}
		if {[string match *immediate $language]} {
			if {![string equal $output$input --]} {
				report E \[$line\] immediate foreign text cannot have variables: ($output)$input
			}
		}
		sym union $alts [sym encode string [list $output $input $language $code]]
	]),<foreigntextor>}
foreign-code-nest
	{((?~code=.*)),((?~N=.*)),<foreigncode>\[}
	{($code\[),([expr {$N+1}]),<foreigncode>}
foreign-code-unnest
	{((?~code=.*)),((?~N=.*)),<foreigncode>\]}
	{($code\]),([expr {$N-1}]),<foreigncode>}
foreign-text-OR-or-END
	{<foreigntextor>[;|]}
	{<foreignrule>}
foreign-text-completed
	{((?~HN=.*)),((?~alts=.*)),<foreigntextor>}
	{(foreign rule),<[
		hr foreigns: +:= $HN
		hr foreign: $HN +:= $alts
		concat endrule
	]>}

		

sym each hn [sym intersect [hr foreigns:] [hr::nonterminals]] {
	report E production cannot be both a hyperrule and a foreign-rule: $hn
	hr::delete foreign: $hn
}
sym each hn [hr foreigns:] {hr $hn := "#NS"}

		

proc grammarProperties {grammar} {
	log Begin grammar properties.
	<Compute grammar properties>
	log Order the vocabulary from terminal to the root production.
	<Order the vocabulary from terminal to the root production>
	log Remove useless productions.
	<Remove useless productions>
	log Remove inaccessible productions.
	<Remove inaccessible productions>
	log Finiteness analysis.
	<Finiteness analysis>
	log Cycle analysis.
	<Cycle analysis>
	log Format the properties of the grammar for reporting.
	<Format the properties of the grammar for reporting>
	$grammar order: := $order
	log Completed grammar properties.
}

		

${grammar}::property weight: {grammar set} {
	if {[sym card $set]==1 && [sym length $set]==1} {return 0}
	sym each alt $set {
		set w 0
		sym enum sym $alt {
			incr w [$grammar weight: [sym first $sym]]
		}
		if {$w==0} {
			;
		} elseif {![info exists W]} {
			set W $w
		} elseif {$W>$w} {
			set W $w
		}
	}
	if {![info exists W]} {set W 0}
	return $W
}

${grammar}::property nullable: {grammar set} {
	if {[sym card $set]==1 && [sym length $set]==1} {error "undefined nullable: $set"}
	set nu 0
	sym each alt $set while {!$nu} {
		set nu 1
		sym enum sym $alt while {$nu} {
			set nu [$grammar nullable: [sym first $sym]]
		}
	}
	return $nu
}

${grammar}::property empty: {grammar set} {
	expr {[$grammar weight: $set]==0}
}

		

set produce {}
sym each pn [${grammar}::nonterminals] {
	sym each alt [${grammar}::if $pn := {}] {
		sym enum member $alt {
			set produce [sym union $produce $pn,$member]
		}
	}
}
set order {}
sym enum forder [sym tsort [sym factor [sym invert $produce]]] {
	set scc [sym member $produce [sym scc $produce $forder]]
	lappend order $scc [sym contains [${grammar}::nonterminals] $scc]
}

		

set neworder {}; $grammar useless: := {}
foreach {scc N} $order {
	sym each sym $scc {
		set useful($sym) [expr {!$N}]
	}
}
foreach {scc N} $order {
	set isUseful 0
	sym each pn $scc while {!$isUseful} {
		if {$useful($pn)} {
			set isUseful 1
		} else {
			sym each alt [$grammar $pn] while {!$isUseful} {
				set isUseful 1
				sym enum member $alt while {$isUseful} {
					set isUseful $useful($member)
				}
			}
		}
	}
	<Prune useless productions of a nonterminal>
}
set order $neworder

		

sym each pn $scc {
	set useful($pn) $isUseful
}
sym each pn $scc {
	if {$isUseful && $N} {
		set newprod {}
		sym each alt [$grammar $pn] {
			set keep 1
			sym enum member $alt while {$keep} {
				set keep $useful($member)
			}
			if {$keep} {set newprod [sym union $newprod $alt]}
		}
		$grammar $pn := $newprod
	} elseif {$N} {
		report I useless production: $pn
		${grammar}::delete $pn
	}
}
if {$isUseful} {
	lappend neworder $scc $N
} else {
	$grammar useless: +:=  $scc
}

		

set accessible {}
$grammar inaccessible: := {}
foreach {scc N} $order {
	sym each sym $scc {
		if {!$N} {
			set accessible [sym union $accessible $sym]
		}
	}
}
vprioq new work -id %start 0 %start
while {[vprioq dequeue work v est; set est]} {
	if {![sym contains [${grammar}::nonterminals] $v]} continue
	set accessible [sym union $accessible $v]
	sym each w [sym from $produce $v] {
		vprioq enqueue work -id $w 0 $w
	}
}
set neworder {}
foreach {scc N} $order {
	if {[sym contains $accessible $scc]} {
		lappend neworder $scc $N
	}
}
set order $neworder
sym each sym [sym diff [${grammar}::nonterminals] $accessible] {
	$grammar inaccessible: +:= $sym
	report I inaccessible production: $sym
}

		

foreach {scc N} $order {
	set sccfinite 1
	sym each v $scc while {$sccfinite} {
		sym each w [sym from $produce $v] while {$sccfinite} {
			if {[sym scc $produce $v]==[sym scc $produce $w]} {
				set sccfinite 0
			} elseif {[info exists finite($w)] && !$finite($w)} {
				set sccfinite 0
			}
		}
	}
	sym each v $scc {
		set finite($v) $sccfinite
	}
}
set U {}
foreach {v sccfinite} [array get finite] {
	if {$sccfinite} {set U [sym union $U $v]}
}
$grammar finite: := $U

		

set type [${grammar}::if type: := 3]
if {$type>=3} {
	$grammar type: 3
} else {
	$grammar type: 2
}
$grammar anyright: := 0
foreach {scc N} $order {
	<Initialise the derivations for a nested grammar>
	while {[vprioq dequeue s derivation est; set est]} {
		<Characterise the current derivation>
		if {$rcr} {
			if {[info exists W1($v)] && $w>=$W1($v) && [$grammar type:]==2} {
				<Abandon a recursive derivation that contributes no new information>
			} elseif {$j<0} {
				<Catalog a immediately recursive derivation>
			} else {
				<Expand a recursive derivation which is not immediately recursive>
			}
		} else {
			<Weigh a nonrecursive derivation>
		}
	}
	<Decide the weight after considerring all derivations>
}

		

set comp [sym scc $produce [sym choose $scc]]
vprioq new s
sym each v $scc {
	set R($v) {}
	if {$N} {
		set WE($v) 0
		$grammar nullable: $v := 0
		sym each alt [$grammar $v] {
			set derived [sym concat $v $alt]
			set alt [sym label $alt string from $v]
			for {set i 0} {$i<[sym length $alt]} {incr i} {set alt [sym label $alt $i prods $derived]}
			vprioq enqueue s -id $alt $alt
		}
	} else {
		set WE($v) 1
		set W1($v) 1
		$grammar nullable: $v := 0
	}
}

		

set v [sym label $derivation string from]
set w 0; unset -nocomplain mw
set rcr 0; set j -1; set nelem [sym length $derivation]
for {set i 0 } {$i<$nelem} {incr i} {
	set sym [sym unlabel [sym index $derivation $i]]
	if {[sym scc $produce $sym]==$comp} {
		if {$i>0 && $i+1<$nelem} {$grammar type: := 2}
		if {$i>0 && $i+1==$nelem} {
			$grammar anyright: := 1
		}
		if {![string equal $sym $v]} {
			set j $i
		}
		incr rcr
		if {$rcr>1} {$grammar type: := 2}
	} else {
		if {![$grammar nullable: $sym]} {
			incr w $WE($sym)
		} elseif {$WE($sym)>0 && (![info exists mw] || $WE($sym)<$wm)} {
			set wm $WE($sym)
		}
	}
}

		

;

		

lappend R($v) $w

		

set sym [sym index $derivation $j]
set oldrules [sym label $derivation $j prods]
sym each alt [$grammar $sym] {
	set rule [sym concat $sym $alt]
	if {[sym contains $oldrules $rule]} continue
	set newrules [sym union $oldrules $rule]
	for {set k 0} {$k<[sym length $alt]} {incr k} {set alt [sym label $alt $k prods $newrules]}
	set newderivation [sym label [
		sym concat [
			sym range $derivation 0 [expr {$j-1}]
		] $alt [
			sym range $derivation [expr {$j+1}] end
		]
	] string from $v]
	vprioq enqueue s -id $newderivation [sym length $newderivation] $newderivation
}

		

if {$w==0} {
	$grammar nullable: $v := 1
	if {[info exists wm]} {set w $wm}
}
if {$w>0 && (![info exists W1($v)] || $w<$W1($v))} {
	set W1($v) $w
}

		

sym each v $scc {
	if {![info exists W1($v)]} {
		set W1($v) 0
		$grammar nullable: $v := 1
		foreach w $R($v) {
			if {$w>0 && ($W1($v)==0 || $w<$W1($v))} {
				set W1($v) $w
			}
		}
	}
	set WE($v) $W1($v)
	array unset R $v
	$grammar weight: $v := $WE($v)
}

		

if {![sym contains [${grammar}::nonterminals] %start] || ![${grammar}::if %start]} {
	report E grammar is useless: [$grammar name:]
	$grammar type: := -1
}
sym each w [${grammar}::terminals] {
	$grammar properties: $w := terminal
}

set finites [$grammar finite:]
sym each pn [${grammar}::nonterminals] {
	try {
		if {[string equal $pn %start]} {
			$grammar properties: $pn := "[${grammar}::if properties: $pn := {}]type-[$grammar type:] "
		}
		if {[$grammar weight: $pn]==0} {
			$grammar properties: $pn := "[${grammar}::if properties: $pn := {}]empty"
		} else {
			if {[$grammar nullable: $pn]} {
				$grammar properties: $pn := "[${grammar}::if properties: $pn := {}]nullable "
			}
			$grammar properties: $pn := "[${grammar}::if properties: $pn := {}]weight=[$grammar weight: $pn]"
		}
		if {[sym contains $finites $pn]} {
			$grammar properties: $pn := "[${grammar}::if properties: $pn := {}] finite"
		} else {
			$grammar properties: $pn := "[${grammar}::if properties: $pn := {}] infinite"
		}
	} {reset error} {
		$grammar properties: $pn := "[${grammar}::if properties: $pn := {}] (!! $rs !!)"
	}
}
sym each sym [$grammar useless:] {
	$grammar properties: $sym := "[${grammar}::if properties: $sym := {}]useless"
}
sym each sym [$grammar inaccessible:] {
	$grammar properties: $sym := "[${grammar}::if properties: $sym := {}]inaccessible"
}

		

<Encode hypernotion for vw1 parsing>
<substituteMetanotions>
<Earley parser>
<Recursively replace hypernotions in rewrite rules with signatures>

proc vW1 {} {
	log Begin vw1 extraction
	set definingATTRIBUTE [expr {![mr::if ATTRIBUTE]}]
	if {$definingATTRIBUTE} {mr ATTRIBUTE := /ATTRIBUTE/}
	log Catalog metanotions.
	<Catalog metanotions>
	log Partition metanotions into context-free and context-sensitive.
	<Partition metanotions into context-free and context-sensitive>
	log Define ATTRIBUTE metanotion.
	<Define ATTRIBUTE metanotion>
	log Eliminate recursive context-free metanotions.
	<Eliminate recursive context-free metanotions>
	log Eliminate finite context-free metanotions.
	<Eliminate finite context-free metanotions>
	log Find signatures of all hypernotions.
	<Find signatures of all hypernotions>
	log Find signatures of symbol table predicates.
	set predicates {}
	set immediates {}
	<Find signatures of symbol table predicates>
	log Rewrite the hyperrules as a context-free grammar + attributes.
	<Rewrite the hyperrules as a context-free grammar + attributes>
	<Replace hypernotions in rewrite rules with signatures>
	log Extract symbol definitions from the grammar.
	<Extract symbol definitions from the grammar>
	grammarProperties hr
	log Delete predicates from the context free grammar.
	<Delete predicates from the context free grammar>
	sym each sym [hr::terminals] {
		if {![string match *symbol $sym] && ![string match *character $sym] && ![string equal %end $sym]} {
			report I non-symbol is a terminal: $sym
		}
	}
	log Complete vw1 extraction.
}

		

set MT {}
set S 0
set D {}
sym each mn [mr::nonterminals] {
	set def [mr $mn]
	set s 0; set d 1
	foreach m [split $mn ""] {
		set d [expr {$d && [string match {[0-9]} $m]}]
		if {![vassoc get MT -exact est $s:$m ns; set est]} {
			incr S; set ns $S
			vassoc put MT $s:$m $ns
		}
		set s $ns
	}
	vassoc put MT $s:. [list 1 $mn]
	if {!$d} {lappend D $mn $s}
}
foreach {mn s} $D {
	foreach m {0 1 2 3 4 5 6 7 8 9} {
		if {![vassoc get MT -exact est $s:$m ns; set est]} {
			incr S; set ns $S
			vassoc put MT $s:$m $ns
		}
		if {[vassoc get MT -exact est $ns:. r; set est] && ![string equal $r [list 0 $mn$m]]} {
			report E conflicting metanotion definitions: $mn$m
		}
		vassoc put MT $ns:. [list 0 $mn$m]
	}
}

sym each mn [mr::nonterminals] {
	sym each alt [mr $mn] {
		ensymbolHypernotion $alt
	}
}
sym each pn [hr::nonterminals] {
	ensymbolHypernotion $pn
	sym each alt [hr $pn] {
		sym enum member $alt {
			ensymbolHypernotion $member
		}
	}
}
set digitalExtensor {}
foreach {tsub u} [mr::filter sub: *] {
	setp {sub t} $tsub
	mr $t := $u
	set digitalExtensor [sym union $digitalExtensor $t]
}

		

proc ensymbolHypernotion {hypernotion {terminalise 0}} {
	upvar 1 MT MT
	if {[sym empty $hypernotion] || [string length $hypernotion]==0} {
		set string ,#NS
		set hypernotion ""
	} else {
		set string ""
	}
	while {[string length $hypernotion]} {
		if {[regexp {^([()a-z%])(.*)$} $hypernotion - smallmark rest]} {
			set hypernotion $rest
			append string ,$smallmark
		} elseif {[regexp {^(/[A-Z0-9]+/)(.*)$} $hypernotion - terminalisedmark rest]} {
			set hypernotion $rest
			append string ,$terminalisedmark
		} elseif {[regexp {^([A-Z0-9]+)(.*)$} $hypernotion - largemarks rest]} {
			set hypernotion $rest
			vprioq new parse 0 [list 0 $largemarks ""]
			set OUT {}
			while {[vprioq dequeue parse task est; set est]} {
				setp {s in out} $task
				if {[string length $in]==0 && $s==0} {
					lappend OUT $out
				} else {
					if {[vassoc get MT -exact est $s:. ct; set est]} {
						setp {catalogged t} $ct
						if {!$catalogged} {
							set u [string range $t 0 end-1]
							mr base: $u +:= $t
							mr sub: $t := $u
							vassoc put MT $s:. [list 1 $t]
						}
						if {$terminalise} {set t /$t/}
						vprioq enqueue parse [list 0 $in $out,$t]
					}
					if {[string length $in]} {
						if {[vassoc get MT -exact est $s:[string index $in 0] ns; set est]} {
							vprioq enqueue parse [list $ns [string range $in 1 end] $out]
						}
					}
				}
			}
			switch [llength $OUT] {
				0 {
					report E unrecognised metanotions: $largemarks in $hypernotion
					set OUT [list ,$largemarks]
				}
				1 {
					;
				}
				default {
					set AMB {}
					foreach out $OUT {
						lappend AMB [string map {/ {}} [string range $out 1 end]]
					}
					report E ambiguous metanotions: [join $AMB |] in $hypernotion
				}
			}
			append string [lindex $OUT 0]
		} else {
			error "bad character in hypernotion: $hypernotion"
		}
	}
	string range $string 1 end
}

		

proc substituteMetanotions {hn pn} {
	upvar 1 eq eq
	upvar 1 MT MT
	set hnsubst ""
	sym enum piece [ensymbolHypernotion $hn] {
		if {[info exists eq($piece)]} {
			sym enum eqnotion $eq($piece) {
				append hnsubst $eqnotion
			}
		} else {
			append hnsubst $piece
		}
	}
	sym encode string $hnsubst
}

		

mr %start := [mr::nonterminals]
sym each mn [mr::nonterminals] {
	set alts1 {}
	sym each alt [mr $mn] {
		set alts1 [sym union $alts1 [ensymbolHypernotion $alt]]
	}
	mr $mn := $alts1
}
grammarProperties mr
mr::delete %start

set possiblecfmetanotions {}
set definitecsmetanotions [mr::if attributes: := {}]
sym each mn $digitalExtensor {
	if {[sym contains $definitecsmetanotions [string range $mn 0 end-1]]} {
		set definitecsmetanotions [sym union $definitecsmetanotions $mn]
	}
}
set finites [sym diff [sym intersect [mr::if finite: := {}] [mr::nonterminals]] $definitecsmetanotions]
set infinites [sym diff [mr::nonterminals] $finites]
sym each pn [hr::nonterminals] {
	set leftMNs {}
	set rightMNs {}
	sym enum p [ensymbolHypernotion $pn] {
		if {[string match {[A-Z0-9]*} $p]} {set leftMNs [sym union $leftMNs $p]}
	}
	sym each alt [hr $pn] {
		sym enum member $alt {
			sym enum p [ensymbolHypernotion $member] {
				if {[string match {[A-Z0-9]*} $p]} {set rightMNs [sym union $rightMNs $p]}
			}
		}
	}
	set possiblecfmetanotions [sym union $possiblecfmetanotions $leftMNs]
	set definitecsmetanotions [sym union $definitecsmetanotions [sym diff $rightMNs $leftMNs]]
}
set additions {}
sym each mn $definitecsmetanotions {
	set additions [sym union $additions [mr::if sub: $mn := {}]]
	set additions [sym union $additions [mr::if base: $mn := {}]]
}
set definitecsmetanotions [sym union $definitecsmetanotions $additions]
set cfmetanotions [sym diff $possiblecfmetanotions $definitecsmetanotions %start]
set csmetanotions [sym diff [mr::nonterminals] $cfmetanotions $finites]
sym each p $csmetanotions {
	mr properties: $p := "[mr::if properties: $p := {}] context-sensitive"
}
sym each p $cfmetanotions {
	mr properties: $p := "[mr::if properties: $p := {}] context-free"
}

		

attribute-property
	{(attribute),<propertyrule>}
	{(),<attributeproperty>}
attribute-property
	{((?~L=.*)),<attributeproperty>(?~R=[0-9A-Z]+)}
	{($L$R),<attributeproperty>}
attribute-property
	{((?~MN=.*)),<attributeproperty>[,;|]}
	{(),<[mr attributes: +:= $MN; concat attributeproperty]>}
attribute-property
	{((?~MN=.*)),<attributeproperty>}
	{(attribute property),<[mr attributes: +:= $MN; concat endrule]>}

		

set aleph 1
sym each attribute [mr::if attributes: := {}] {
	if {![mr::if $attribute]} {
		mr $attribute := aleph%[string map {0 a 1 b 2 c 3 d 4 e 5 f 6 g 7 h 8 i 9 j} $aleph]
		incr aleph
	}
}

		

if {$definingATTRIBUTE} {
	set prods $csmetanotions
	sym each mn $csmetanotions {
		if {[mr::if base: $mn]} {
			set prods [sym diff $prods $mn]
		}
	}
	mr ATTRIBUTE := $prods
	set cfmetanotions [sym diff $cfmetanotions ATTRIBUTE]
	set csmetanotions [sym union $csmetanotions ATTRIBUTE]
}

		

proc earley {grammar hn} {
	$grammar start: !
	string map {/ ""} [${grammar}::parse $hn]
}

		

set prods {}
sym each pn [hr::nonterminals] {
	set hn [ensymbolHypernotion $pn 0]
	set parts [string map {, |} $hn]
	if {![sym null [sym intersect $cfmetanotions $parts]] && [sym null [sym intersect $csmetanotions $parts]]} {
		set prods [sym union $prods $hn]
	}
}
if {![sym null $prods]} {
	sym grammar [namespace current]::cfgrammar
	cfgrammar start: := !
	cfgrammar ! := $prods
	<Select a subset of metarules to eliminate the context-free metanotions>
	vprioq new work
	set handled [hr::nonterminals]
	sym each pn [hr::nonterminals] {vprioq enqueue work -id $pn $pn}
	while {[vprioq dequeue work pn est; set est]} {
		sym each alt [hr $pn] {
			sym enum member $alt {
				if {![sym contains $handled $member]} {
					set handled [sym union $handled $member]
					log "  parsing $pn: ...$member..."
					set memberstring [ensymbolHypernotion $member 1]
					set derivations [earley cfgrammar $memberstring]
					foreach derivation $derivations {
						set derivation [lrange $derivation 0 end-2]
						set stack {}
						foreach {n X} $derivation {
							if {$n<0} {
								lappend stack 1 $X $X
							} else {
								set p [expr {[llength $stack]-3*$n}]
								set substring ""
								foreach {terminal A a} [lrange $stack $p end] {
									append substring $a
								}
								set stack [lreplace $stack $p end 0 $X $substring]
							}
						}
						set cons ""
						array unset eq *
						foreach {terminal A a} $stack {
							append cons $A
							if {!$terminal} {set eq($A) $a}
						}
						set cons1 [substituteMetanotions $cons $pn]
						set consalts1 {}
						sym each consalt [hr $cons] {
							set consalt1 "#NS"
							sym enum consmember $consalt {
								set consalt1 [sym concat $consalt1 [substituteMetanotions $consmember $cons]]
							}
							set consalts1 [sym union $consalts1 $consalt1]
						}
						log "    adding: $cons1: $consalts1"
						hr $cons1 +:= $consalts1
						vprioq enqueue work -id $cons1 $cons1
					}
				}
			}
		}
	}
	rename cfgrammar ""
}
unset -nocomplain work

		

set mnsToBeAdded {}
set members {}
vprioq new work
sym each mn $cfmetanotions {
	vprioq enqueue work -id $mn $mn
	set members [sym union $members $mn]
}
while {[vprioq dequeue work mn est; set est]} {
	if {!$definingATTRIBUTE || ![string equal $mn ATTRIBUTE]} {
		sym each alt [mr::if $mn := {}] {
			sym enum member $alt {
				if {[string match {[A-Z0-9]*} $member]} {
					vprioq enqueue work -id $member $member
					set members [sym union $members $member]
				}
			}
		}
	}
	lappend mnsToBeAdded $mn [sym union /$mn/ [mr::if $mn := {}]]
}
sym each mn [sym diff [mr::nonterminals] $members] {
	lappend mnsToBeAdded $mn /$mn/
}
foreach {mn prods} $mnsToBeAdded {
	sym each mnx [mr::if base: $mn := {}] {
		set prods [sym union $prods /$mnx/]
		cfgrammar $mnx := $mn
	}
	if {[mr::if sub: $mn]} {
		set prods [mr sub: $mn]
	}
	cfgrammar $mn := $prods
}

		

array set finiteCache {}
proc expandFinite {mn} {
	upvar 1 finiteCache finiteCache
	upvar 1 finites finites
	if {[mr::if sub: $mn]} {set mn [mr sub: $mn]}
	if {![info exists finiteCache($mn)]} {
		set finiteCache($mn) {}
		sym each alt [mr $mn] {
			set exp "#NS"
			sym enum notion $alt {
				if {[sym contains $finites $notion]} {
					set exp [sym concat $exp [expandFinite $notion]]
				} else {
					set exp [sym concat $exp $notion]
				}
			}
			set finiteCache($mn) [sym union $finiteCache($mn) $exp]
		}
	}
	return $finiteCache($mn)
}

proc replaceFinite {finites map hn alt} {
	upvar 1 MT MT
	if {[llength $finites]} {
		set finites [setp {finite pns} $finites]
		sym each pn $pns {
			replaceFinite $finites [concat $map $finite $pn] $hn $alt
		}
	} else {
		array set eq $map
		set hn1 [substituteMetanotions $hn $hn]
		if {[string equal $alt %signature]} {
			hr signatures: +:= $hn1
		} else {
			set alt1 "#NS"
			sym enum member $alt {
				set alt1 [sym concat $alt1 [substituteMetanotions $member $hn]]
			}
			hr $hn1 +:= $alt1
		}
	}
}

sym each hn [hr::nonterminals] {
	sym each alt [hr $hn] {
		set s [sym encode set [sym decode string [ensymbolHypernotion $hn]]]
		sym enum member $alt {
			set s [sym union $s [sym encode set [sym decode string [ensymbolHypernotion $member]]]]
		}
		set s [sym intersect $s $finites]
		if {![sym null $s]} {
			hr $hn -:= $alt
			set exps {}
			sym each mn $s {
				lappend exps $mn [expandFinite $mn]
			}
			replaceFinite $exps {} $hn $alt
		}
	}
}
set signatures [hr::if signatures: := {}]
hr signatures: := {}
sym each sn $signatures {
	set s [sym intersect [sym encode set [sym decode string [ensymbolHypernotion $sn]]] $finites]
	if {[sym null $s]} {
		hr signatures: +:= $signature
	} else {
		set exps {}
		sym each mn $s {
			lappend exps $mn [expandFinite $mn]
		}
		replaceFinite $exps {} $sn %signature
	}
}
unset -nocomplain finiteCache

		

<Lexical attribute variables>
sym grammar [namespace current]::csgrammar
csgrammar start: := !
csgrammar ! := ATTRIBUTE,%,e,q,%,ATTRIBUTE|ATTRIBUTE,%,n,e,%,ATTRIBUTE
set mnmap {/ {}}
vprioq new work
sym each mn $csmetanotions {
	sym each alt [mr $mn] {
		set finite 1
		sym enum mem $alt while {$finite} {
			set finite [expr {[string match {[a-z()%]*} $mem] || [sym contains $finites $mem]}]
		}
		if {$finite} {
			vprioq enqueue work -id $mn:$alt [list $mn $alt]
		}
	}
}
set finiteexpansions {}
while {[vprioq dequeue work task est; set est]} {
	setp {mn expansion} $task
	set indices {}
	set newre ""
	set i 0
	sym enum mem $expansion {
		if {[string match {[A-Z0-9]*} $mem]} {
			lappend indices $i
			append newre $mem\\d?
		} else {
			append newre $mem
		}
		incr i
	}
	lappend finiteexpansions $newre $mn
	foreach i $indices {
		set mem [sym index $expansion $i]
		set l [sym range $expansion 0 $i-1]
		set r [sym range $expansion $i+1 end]
		sym each alt [mr $mem] {
			set newexpansion [sym concat $l $alt $r]
			vprioq enqueue work -id $mn:$newexpansion [list $mn $expansion]
		}
	}
}
vprioq new work
sym each mn $csmetanotions {
	vprioq enqueue work -id $mn $mn
}
while {[vprioq dequeue work mn est; set est]} {
	csgrammar $mn := {}
	if {![sym contains $digitalExtensor $mn]} {
		csgrammar $mn +:= /$mn/
	}
	sym each hn [mr $mn] {
		csgrammar $mn +:= $hn
		sym enum mem $hn {
			if {[string match {[A-Z0-9]*} $mem]} {
				vprioq enqueue work -id $mem $mem
			}
		}
	}
	sym each mnx [mr::if base: $mn := {}] {
		csgrammar $mn +:= /$mnx/
		csgrammar $mnx := $mn
		lappend mnmap $mnx $mn
	}
}
sym each hn [hr::if signatures: := {}] {
	foreach {re mn} $finiteexpansions {
		regsub -all $re $hn $mn hn
	}
	csgrammar ! +:= [ensymbolHypernotion $hn 0]
}
vprioq new work
sym each pn [hr::nonterminals] {
	set hn [ensymbolHypernotion $pn 1]
	vprioq enqueue work -id $hn [sym length $hn] [list $pn $hn]
	set reduced 0; set red $pn
	foreach {re mn} $finiteexpansions {
		if {[regsub -all $re $red $mn red]} {
			set reduced 1
		}
	}
	if {$reduced} {
		set hn [ensymbolHypernotion $red 1]
		vprioq enqueue work -id $hn [sym length $hn] [list $red $hn]
	}
	sym each alt [hr $pn] {
		sym enum member $alt {
			set hn [ensymbolHypernotion $member 1]
			vprioq enqueue work -id $hn [sym length $hn] [list $member $hn]
			set reduced 0; set red $member
			foreach {re mn} $finiteexpansions {
				if {[regsub -all $re $red $mn red]} {
					set reduced 1
				}
			}
			if {$reduced} {
				set hn [ensymbolHypernotion $red 1]
				vprioq enqueue work -id $hn [sym length $hn] [list $red $hn]
			}
		}
	}
}
<Add tree rewrite node names to the signature work list>
while {[vprioq dequeue work pnhn est; set est]} {
	setp {pn hn} $pnhn
	set parsePrograms [earley csgrammar $hn]
	if {[llength $parsePrograms]} {
		foreach parseProgram $parsePrograms {
			set parseProgram [lrange $parseProgram 0 end-2]
			lappend parseProgram 0 !
			set parseStack {}
			foreach {popcount X} $parseProgram {
				set type [string map $mnmap $X]
				if {[string equal $X !]} {set popcount [llength $parseStack]}
				if {$popcount<0} {
					if {[string match {[a-z0-9%]*} $X]} {
						lappend parseStack [list $X {}]
					} else {
						lappend parseStack [list $type [sym nest VAR,$X] $type]
					}
				} else {
					set functor {}
					set arguments "#NS"
					set subtypes {}
					foreach entry [lrange $parseStack end-[expr {$popcount-1}] end] {
						setp {subtype entry} $entry
						append functor $subtype
						if {[sym length $entry]} {
							set arguments [sym concat $arguments $entry]
							lappend subtypes $subtype
						}
					}
					set parseStack [lrange $parseStack 0 end-$popcount]
					if {[regexp {^[A-Z0-9_]+$} $functor] && [sym length $arguments]==1} {
						lappend parseStack [list $type $arguments $type]
						<Catalog attributes equated to another metanotion>
					} else {
						<Catalog attributes constructed from other metanotions>
						lappend parseStack [list $type [sym nest [sym concat TERM $functor $arguments]] $subtypes]
					}
				}
			}
			setp {type relation subtypes} [lindex $parseStack end]
			set signature($pn) $relation
			<Verify the signature of a symbol>
			log "  signature $pn = old [displayAttribute $signature($pn)]"
		}
	} elseif {[regexp {^[()a-z]*%(eq|ne)%[()a-z]*$} $hn]} {
		set signature($pn) [sym nest TERM,$hn]
		log "  signature $pn = PROTO [displayAttribute $signature($pn)]"
	} else {
		set arguments "#NS"
		set vars "#NS"
		set functor ""
		csgrammar ! +:= [string map $mnmap $hn]
		sym enum notion $hn {
			append functor [string map $mnmap $notion]
			if {[string match {[/A-Z0-9]*} $notion]} {
				set notion [string map {/ {}} $notion]
				set arguments [sym concat $arguments [sym nest VAR,$notion]]
				set vars [sym concat $vars $notion]
			}
		}
		set signature($pn) [sym nest [sym concat TERM $functor $arguments]]
		log "  signature $pn = new [displayAttribute $signature($pn)]"
		<Generated command: term_vars>
	}
}
rename csgrammar ""

<Verify lexical attributes are not analyzed>
		

signature-property
	{(signature),<propertyrule>}
	{(signatureproperty),<notion>}
hypernotion-signature
	{(.*),((?~notion=.*)),<signatureproperty>}
	{<[hr signatures: +:= $notion; concat signaturepropertynext]>}
signature-property-separator
	{<signaturepropertynext>[,;|]}
	{(signatureproperty),<notion>}
signature-property-end
	{<signaturepropertynext>}
	{(signature property),<endrule>}

		

set vw1 {
	ATTRIBUTE%eq%ATTRIBUTE #NS -
	ATTRIBUTE%ne%ATTRIBUTE #NS -
}
set VW1 ATTRIBUTE%eq%ATTRIBUTE|ATTRIBUTE%ne%ATTRIBUTE
sym each hn [hr::nonterminals] {
	set pn [sym index [sym unnest $signature($hn)] 1]
	if {[hr::if foreign: $hn]} {
		<Massage foreign text into a pseudo-TERM>
	} else {
		sym each alt [hr $hn] {
			set horn $signature($hn)
			set vwalt "#NS"
			set rejected 0
			sym enum member $alt {
				set member1 [sym index [sym unnest $signature($member)] 1]
				set goal $signature($member)
				set lgoal [sym decode string [sym unnest $goal]]
				if {[regexp {^([a-z()]*)%(eq|ne)%([a-z()]*)$} $member1 - a op b]} {
					set rejected [expr {[string equal $a $b]!=[string equal $op eq]}]
					if {$rejected} break
				} elseif {[string first %ne% $member1]>=0} {
					set vwalt [sym concat $vwalt $member1]
					setp {- - p q} $lgoal
					set horn [
						sym concat $horn [
							sym nest [
								sym encode string [list ANTIUNIFY $p $q]
							]
						]
					]
				} elseif {[string first %eq% $member1]>=0} {
					set goal [sym unnest $goal]
					lset lgoal 1 %eq%
					set vwalt [sym concat $vwalt $member1]
					set horn [sym concat $horn [sym nest [sym encode string $lgoal]]]
				} else {
					set vwalt [sym concat $vwalt $member1]
					set horn [sym concat $horn $goal]
				}
			}
			if {!$rejected} {
				lappend vw1 $pn $vwalt $horn
			}
			hr::delete cs: $hn $alt
		}
	}
	hr::delete $hn
}
foreach {pn alt rules} $vw1 {
	hr $pn +:= $alt
	if {![string equal $rules -]} {
		hr cs: $pn $alt +:= $rules
	}
}
foreach {sym sig} [array get signature *symbol] {
	hr cs: [sym index [sym unnest $sig] 1] "#NS" := $sig
}

		

set foreigns [hr foreign: $hn]
set predicates [sym union $predicates $pn]
set disj {}
foreach foreign [sym decode $foreigns] {
	setp {output input language code} $foreign
	if {[string match *immediate $language]} {
		set immediates [sym union $immediates $pn]
	} else {
		set goal FOREIGN,$language
		foreach val [list $output $input] prefix {+ -} {
			if {[string equal $val -]} continue
			sym enum symbol [ensymbolHypernotion $val] {
				set goal [sym concat $goal $prefix$symbol]
			}
		}
		set goal [sym nest [sym concat $goal [sym encode string [list $code]]]]
		set disj [sym union $disj [sym concat $signature($hn) $goal]]
	}
}
lappend vw1 $pn "#NS" $disj

		

sym each pn [hr useless:] {hr::delete $pn}
sym each pn [hr inaccessible:] {hr::delete $pn}
set predicates [sym intersect $predicates [hr::nonterminals]]
vprioq new work
sym each pn [hr::nonterminals] {
	if {[hr empty: $pn] && [sym card [hr $pn]] > 1} {
		vprioq enqueue work -id $pn $pn
	}
}
while {[vprioq dequeue work pn est; set est]} {
	set predicates [sym union $predicates $pn]
	sym each alt [hr::if $pn := {}] {
		sym enum member $alt {
			vprioq enqueue work -id $member $member
		}
	}
}
sym each pn $predicates {
	set cs {}
	foreach {key rule} [hr::filter cs: $pn *] {
		setp {- - alt} $key
		set cs [sym union $cs $rule]
		hr::delete cs: $pn $alt
	}
	hr $pn := "#NS"
	hr cs: $pn "#NS" := $cs
	hr properties: $pn := "[hr::if properties: $pn := {}] predicate"
}
hr predicates: := $predicates
hr immediates: := $immediates
sym each pn [sym union [sym diff [hr::nonterminals] $predicates] $immediates] {
	sym each alt [hr $pn] {
		set changed 0
		set newalt #NS
		sym enum sym $alt {
			if {[sym contains $predicates $sym]} {
				set changed 1
			} else {
				set newalt [sym concat $newalt $sym]
			}
		}
		if {$changed} {
			if {[hr::if cs: $pn $alt]} {
				hr cs: $pn $newalt := [hr cs: $pn $alt]
				hr::delete cs: $pn $alt
			}
			hr $pn -:= $alt
			hr $pn +:= $newalt
		}
	}
}
sym each pn [sym union [sym diff [symr0::nonterminals] $predicates] $immediates] {
	sym each alt [symr0 $pn] {
		set changed 0
		set newalt #NS
		sym enum sym $alt {
			if {[sym contains $predicates $sym]} {
				set changed 1
			} else {
				set newalt [sym concat $newalt $sym]
			}
		}
		if {$changed} {
			if {[symr0::if cs: $pn $alt]} {
				symr0 cs: $pn $newalt := [symr0 cs: $pn $alt]
				symr0::delete cs: $pn $alt
			}
			symr0 $pn -:= $alt
			symr0 $pn +:= $newalt
		}
	}
}

		

proc attributeAnalysis {grammar} {
	log Add tree constructors to grammar attribute rules.
	<WAM constant accumulation buffers>
	<Add tree constructors to grammar attribute rules>
	<The attribute tree construction QUERY>
	<The database %eq% fact>
	set database [list $QUERY $EQFACT]
	log Construct the logic machine.
	<Construct the logic machine>
}
<Display attribute rule>
<Define a WAM constant>
<WAM third level indexing>

		

set predicaterecoveries {}
$grammar action: %end %shift := [sym nest [sym concat shift_lexeme [compileWAMConstant %end 1]  0]]
foreach {key rules} [${grammar}::filter cs: * *] {
	setp {- pn alt} $key
	if {![sym contains [${grammar}::symbols] $pn] && ![sym contains [$grammar predicates:] $pn]} {
		${grammar}::delete cs: $pn $alt
		continue
	} elseif {[string match *symbol $pn]} {
		<Define symbol shift action>
		<A database symbol fact>
	} elseif {[sym contains [$grammar predicates:] $pn]} {
		<Define immediate foreign text reduce action>
		<A database predicate rule>
	} else {
		<Define production reduce action>
		<A database production rule>
	}
}

		

$grammar action: $pn $alt := [sym nest reduce_parse,[compileWAMConstant $pn 1],[sym length $alt]]

		

if {[sym empty $alt]} {
	foreach foreign [sym decode [hr::if foreign: $pn := {}]] {
		setp {language output input code} [sym decode string $foreign]
		if {[string match *immediate $language] && [string length $code]} {
			if {![string equal $output -]} {
				report E immediate foreign text has output: $pn: $output
			}
			if {![string equal $input -]} {
				report E immediate foreign text has input: $pn: $input
			}
			if {[string match *immediate $language]} {
				set language [string range $language 0 end-[string length immediate]]
			}
			symr0 action: $pn $alt := [sym nest [sym encode string foreign_immediate $language $code]]
		}
	}
}

		

set rule [sym choose $rules]
set head [sym unnest [sym first $rule]]
set symbol [sym index $head 1]
set attribute [sym range $head 2 end]
$grammar action: $pn %shift := [sym nest [sym concat shift_lexeme \
		[compileWAMConstant $symbol 1] \
		[expr {![sym empty $attribute] || [sym contains [hr::if namedsymbols: := {}] $symbol]}] \
]]

		

foreach {key rules} [${grammar}::filter cs: * *] {
	setp {- pn alt} $key
	if {![sym contains [${grammar}::nonterminals] $pn] && ![sym contains [$grammar predicates:] $pn]} continue
	sym each rule $rules {lappend database $rule}
}

<Add rewrite rules to the logic database>
<Add predicate recovery rules>
<Add symbol table queries>

<WAM code accumulation buffer>
<WAM query variable list>
<WAM code symbol table>
<Compile rules database into WAM>
<Index the WAM machine>
<Link WAM calls to entry points>
<Section the WAM machine>
<Generate the WAM machine>

		

foreach clause $database {
	set variableAssignments {}
	if {[sym length $clause]==1} {
		<Compile a FACT into WAM>
	} elseif {[string equal [sym first $clause] %query] && [sym length $clause]>=3} {
		<Compile a QUERY into WAM>
	} else {
		<Compile a RULE into WAM>
	}
	<Identify permanent variables in a WAM rule>
	set allocate [llength $permanent0]
	if {$allocate==0 && [llength $tail]<=1} {set allocate -1}
	set deallocate -1
	<Identify useless variables in a WAM rule>
	if {[sym length $head]} {
		<Compile a WAM rule head>
		set allocate -1
	}
	if {[sym length $tail]} {
		<Compile a WAM rule tail>
	} else {
		<Generated command: proceed>
	}
	if {[string equal [sym first $clause] %query] && [sym length $clause]>=3} {
		<Link the QUERY to rest of the world>
	}
}

		

			
lappend C fail

		

			
lappend C pass

		

			
lappend C proceed

		

set n [sym length $alt]
set newrules {}
sym each rule $rules {
	set head [sym rest [sym unnest [sym first $rule]]]
	set Plist [sym nest [sym concat LIST [sym nest VAR,_LOC] NIL]]
	set Alist [sym nest [sym concat LIST [sym nest VAR,_LOC] NIL]]
	for {set i $n} {$i>=1} {incr i -1} {
		set Plist [sym nest [sym concat LIST [sym nest VAR,_P$i] $Plist]]
		set Alist [sym nest [sym concat LIST [sym nest VAR,_A$i] $Alist]]
	}
	<Generated command: term_production>
	if {[rew::if :[sym first $head]]} {
		<Redirect production tree construction to the rewriting rules>
	} else {
		set Alist [sym nest [sym concat TERM $head $Alist]]
		set newrule [sym nest [sym concat TERM [sym first $head] $Plist $Alist [sym rest $head]]]
	}
	set i 1
	sym enum term [sym rest $rule] {
		set term [sym unnest $term]
		if {[sym contains [$grammar predicates:] [sym index $term 1]]} {
			set term [sym concat \
					$term \
					[sym nest [sym encode string [list TERM "[sym index $term 1] in $pn"]]] \
					[sym nest VAR,_LOC]
			]
		} else {
			set term [sym concat \
					[sym range $term 0 1] \
					[sym nest VAR,_P$i] \
					[sym nest VAR,_A$i] \
					[sym range $term 2 end] \
			]
			incr i 
		}
		set newrule [sym concat $newrule [sym nest $term]]
	}
	set newrules [sym union $newrules $newrule]
}
$grammar cs: $pn $alt := $newrules

		

		
set newrules {}
set head "#NS"
sym each rule $rules {
	set head [sym unnest [sym first $rule]]
	set newrule [sym nest [sym concat \
			$head \
			[sym nest VAR,_RECOVERY] \
			[sym nest VAR,_LOC] \
	]]
	sym enum term [sym rest $rule] {
		set term [sym nest [sym concat [sym unnest $term] [sym nest VAR,_] [sym nest VAR,_]]]
		set newrule [sym concat $newrule $term]
	}
	set newrule [sym concat $newrule [sym nest SUCCESS,_RECOVERY]]
	set newrules [sym union $newrules $newrule]
}
$grammar cs: $pn $alt := $newrules
<Define predicate recovery term>

		

set database [concat $database $predicaterecoveries]

		

if {[sym length $head]>=2} {
	set n [expr {[sym length $head]-2}]
	set predicaterecovery [sym range $head 0 1]
	for {set i 2} {$i<$n} {incr i} {
		set predicaterecovery [sym concat $predicaterecovery [sym nest VAR,_]]
	}
	set predicaterecovery [sym concat $predicaterecovery [sym nest VAR,_RECOVERY]]
	set predicaterecovery [sym concat $predicaterecovery [sym nest VAR,_LOC]]
	set predicaterecovery [sym concat [sym nest $predicaterecovery] [sym nest FAILURE,_RECOVERY,_LOC]]
	lappend predicaterecoveries $predicaterecovery
}

		

set head [sym first $clause]
set tail [sym rest $clause]
set queryvar 0

		

set QUERY %query,%start,[sym nest TERM,%start,[sym nest VAR,P_0],[sym nest VAR,A_0]]

		

set head "#NS"
set queryname [sym index $clause 1]
set tail [sym range $clause 2 end]
if {[string equal $queryname %start]} {
	set querystart [llength $C]
	set Y(a.[llength $C]) %query
} else {
	<Record the subquery address>
}

		

if {[string equal $queryname %start]} {
	<Generated command: query_start>
} else {
	<Generated command: subquery_start>
	hr symbol-table: $SYMTAB := [
		assoc update [hr symbol-table: $SYMTAB] $objkey wamcode {
			set wamcode [list $wamcode $variableAssignments]
		}
	]
}
<Generated command: pass>

		

			
lappend C [list query_start C.$querystart $variableAssignments]

		

			
lappend C [list subquery_start $queryname C.$querystart $variableAssignments]

		

set EQFACT [sym nest TERM,%eq%,[sym nest VAR,ATTRIBUTE],[sym nest VAR,ATTRIBUTE],[sym nest VAR,_]]

		

		
set newrules {}
sym each rule $rules {
	set head [sym unnest [sym first $rule]]
	set symbol [sym index $head 1]
	set attribute [sym range $head 2 end]
	if  {[sym empty $attribute] && [sym contains [hr::if namedsymbols: := {}] $symbol]} {
		set attribute [sym nest VAR,_NAME]
	}
	set core [sym nest LIST,[sym nest VAR,_LOC],NIL]
	if {![sym empty $attribute]} {
		set core [sym nest LIST,$attribute,$core]
		gen term_production $symbol 2
	}
	set newrules [sym concat $newrules [
		sym nest [sym concat \
			TERM \
			$symbol \
			$core \
			[sym nest [sym concat TERM $symbol $attribute $core]] \
			$attribute \
		] \
	]]
}
$grammar cs: $pn $alt := $newrules

		

set head [sym first $clause]
set choices "#NS"
set queryvar 0

		

<Convert to a parse tree to a top down flattenned list>
set a 1
set o [expr {[lindex $flattenned 1]+1}]
array set map {}; array unset map *
array set pam {}; array unset pam *
array set def {}; array unset def *
set permanent {}
foreach p $permanent0 {
	setp {v client} $p
	lappend permanent $v
}
foreach {d n f} $flattenned {
	if {$d==0} {
		if {[info exists Y(e.$f/$n)]} {
			if {[info exists Y(t.$f/$n)]} {
				lset C $Y(t.$f/$n) [list retry_me_else [llength $C]]
			} else {
				lset C $Y(e.$f/$n) [list try_me_else [llength $C] $n]
			}
			set Y(t.$f/$n) [llength $C]
			<Generated command: trust_me>
		} else {
			set Y(e.$f/$n) [llength $C]
			set Y(a.[llength $C]) $f/$n
			<Generated command: nop>
		}
		if {![info exists Y(f.$f/$n)]} {set Y(f.$f/$n) {}}
		if {$allocate>=0} {
			<Generated command: allocate>
		}
	} elseif {$n==-1} {
		if {[string equal $f _] || [lsearch -exact $useless $f]>=0} {
			if {$d==1} {
				incr a
			} else {
				<Generated command: unify_void>
			}
		} elseif {[info exists map($f)]} {
			if {$d==1} {
				<Generated command: get_value>
				incr a
			} else {
				if {[info exists def($map($f))] && $def($map($f))==2} {
					<Generated command: unify_value>
				} else {
					set def($map($f)) 2
					if {[string match Y* $map($f)]} {
						error "unify_local_value $map($f) = $f"
					}
					<Generated command: unify_local_value>
				}
			}
		} else {
			set i [lsearch -exact $permanent $f]
			if {$i>=0} {
				incr i
				set map($f) Y.$i
			} else {
				set map($f) X.$o
				incr o
			}
			if {$d==1} {
				<Generated command: get_variable>
				incr a
			} else {
				set def($map($f)) 2
				set tr $map($f)
				<Generated command: unify_variable>
			}
		}
	} elseif {$n==0} {
		if {$d==1} {
			set r $a; incr a
			<Generated command: get_constant>
		} else {
			<Generated command: unify_constant>
		}
	} else {
		if {$d==1} {
			set r $a; incr a; set tr A.$r
		} else {
			set r $o; incr o; set tr X.$r
		}
		if {$d>1} {
			set def($tr) 2
			<Generated command: unify_variable>
		}
		if {[string equal $f LIST]} {
			<Generated command: get_list>
		} else {
			<Generated command: get_structure>
		}
	}
}

		

			
lappend C [list allocate $allocate]

		

			
lappend C [list get_constant [compileWAMConstant $f 0] A.$r]

		

			
lappend C [list get_list $tr]

		

			
lappend C [list get_structure [compileWAMConstant $f $n] $tr]

		

			
lappend C [list get_value $map($f) A.$a]

		

			
lappend C [list get_variable $map($f) A.$a]

		

			
lappend C nop

		

			
lappend C trust_me

		

			
lappend C [list unify_constant [compileWAMConstant $f 0]]

		

			
lappend C [list unify_local_value $map($f)]

		

			
lappend C [list unify_value $map($f)]

		

			
lappend C [list unify_variable $tr]

		

			
lappend C [list unify_void 1]

		

set flattenned {}
vprioq new work 0 [list 0 $head]
while {[vprioq dequeue work task est; set est]} {
	setp {d list} $task
	if {[sym nested $list]} {set list [sym unnest $list]}
	switch [sym first $list] {
		TERM {
			set functor [sym index $list 1]
			set terms [sym range $list 2 end]
			lappend flattenned $d [sym length $terms] $functor
			incr d
			while {![sym empty $terms]} {
				vprioq enqueuebefore work [list $d [sym last $terms]]
				set terms [sym front $terms]
			}
		}
		VAR {
			lappend flattenned $d -1 [sym last $list]
		}
		NIL {
			lappend flattenned $d 0 %nil
		}
		LIST {
			set list [sym rest $list]
			lappend flattenned $d 2 LIST
			incr d
			while {![sym empty $list]} {
				vprioq enqueuebefore work [list $d [sym last $list]]
				set list [sym front $list]
			}
		}
	}
}

		

array set map {}
array set pam {}
array set def {}
set m 0; set le0 [llength $permanent0]
set trim [expr {$deallocate>=0}]
sym enum term $tail {
	incr m
	<Convert to a parse tree to a bottom up flattenned list>
	set a 1
	set o [expr {[lindex $flattenned end-1]+1}]
	set R {}
	set permanent {}
	set unsafe {}
	set le 0
	foreach p $permanent0 {
		setp {v client} $p
		if {$m<=$client} {lappend permanent $v}
		if {$m<$client} {incr le} else {lappend unsafe $v}
	}
	if {$allocate>=0} {
		<Generated command: allocate>
		set allocate -1
	}
	foreach {d n f} $flattenned {
		if {$d==0 && $n>=0} {
			if {$m==[llength $tail]} {
				if {$deallocate>=0} {
					<Generated command: deallocate>
					set deallocate -1
				}
				lappend Y(f.$f/$n) [llength $C]
				<Generated command: call>
			} else {
				if {$trim && $le<$le0} {
					<Generated command: trim_environment>
				}
				lappend Y(f.$f/$n) [llength $C]
				<Generated command: call>
			}
		} elseif {$n==-2} {
			<Generated command: anti_get_value>
			if {$m==[llength $tail]} {
				if {$deallocate>=0} {
					<Generated command: deallocate>
					set deallocate -1
				}
				<Generated command: proceed>
			} elseif {$trim && $le<$le0} {
				<Generated command: trim_environment>
			}
		} elseif {$n==-3} {
			<Generated command: on_failure>
			if {$m==[llength $tail]} {
				if {$deallocate>=0} {
					<Generated command: deallocate>
					set deallocate -1
				}
				<Generated command: proceed>
			} elseif {$trim && $le<$le0} {
				<Generated command: trim_environment>
			}
		} elseif {$n==-4} {
			setp {language no ni varnames foreigntext} $f
			<Generated command: foreign_text>
			if {$m==[llength $tail]} {
				if {$deallocate>=0} {
					<Generated command: deallocate>
					set deallocate -1
				}
				<Generated command: proceed>
			} elseif {$trim && $le<$le0} {
				<Generated command: trim_environment>
			}
		} elseif {$n==-5} {
			set i [expr {$a-1}]
			<Generated command: if_bound>
		} elseif {$n==-6} {
			<Generated command: on_success>
			if {$m==[llength $tail]} {
				if {$deallocate>=0} {
					<Generated command: deallocate>
					set deallocate -1
				}
				<Generated command: proceed>
			} elseif {$trim && $le<$le0} {
				<Generated command: trim_environment>
			}
		} elseif {$n==-1} {
			if {[string equal $f _]} {
				if {$d==1} {
					<Generated command: put_void>
					incr a
				} else {
					lappend R _
				}
			} elseif {[info exists map($f)]} {
				if {$d==1} {
					set i [lsearch -exact $unsafe $f]
					if {$i>=0} {
						set unsafe [lreplace $unsafe $i $i]
						<Generated command: put_unsafe_value>
					} else {
						<Generated command: put_value>
					}
					set def(A.$a) 1
					set pam(A.$a) $f
					incr a
				} else {
					lappend R $map($f)
				}
			} else {
				set i [lsearch -exact $permanent $f]
				if {$i>=0} {
					incr i
					set map($f) Y.$i
					set pam(Y.$i) $f
				} else {
					set map($f) X.$o
					set pam(X.$o) $f
					incr o
				}
				if {$d==1} {
					<Generated command: put_variable>
					lappend variableAssignments $f $map($f)
					set def(A.$a) 2
					set pam(A.$a) $f
					if {[string match Y.* $map($f)]} {
						set def($map($f)) 1
					} else {
						set def($map($f)) 2
					}
					incr a
				} else {
					lappend R $map($f)
					set def($map($f)) 0
				}
			}
		} elseif {$n==0} {
			if {$d==1} {
				set r $a; incr a
				<Generated command: put_constant>
			} else {
				lappend R [compileWAMConstant $f 0]
			}
			
		} else {
			set i [expr {[llength $R]-1}]
			set j [expr {[llength $R]-$n}]
			set R0 [lrange $R $j $i]
			set R [lrange $R 0 [expr {$j-1}]]
			if {$d==1} {
				set r $a; incr a; set tr A.$r
			} else {
				set r $o; incr o; set tr X.$r
			}
			lappend R $tr
			set def($tr) 1
			set pam($tr) -
			if {[string equal $f LIST]} {
				<Generated command: put_list>
			} else {
				<Generated command: put_structure>
			}
			foreach r $R0 {
				if {[string equal $r _]} {
					<Generated command: set_void>
				} elseif {[string match C.* $r]} {
					<Generated command: set_constant>
				} elseif {$def($r)==2} {
					<Generated command: set_value>
				} elseif {$def($r)} {
					set def($r) 2
					if {[string match Y* $r]} {error "set_local_value $r"}
					<Generated command: set_local_value>
				} else {
					set def($r) 2
					<Generated command: set_variable>
					if {![string equal $pam($r) -]} {
						lappend variableAssignments $pam($r) $r
					}
				}
			}
		}
	}
	foreach {v x} [array get map] {
		if {![string match Y.* $x]} {
			unset map($v)
			if {[info exists pam($x)]} {
				unset pam($x)
				unset def($x)
			}
		}
	}
	set le0 $le
}
if {$deallocate>=0} {
	<Generated command: deallocate>
}

		

			
lappend C [list anti_get_value A.1 A.2]

		

			
lappend C [list call $f/$n $n 0]

		

			
lappend C deallocate

		

			
lappend C [list execute $f/$n 0 $n]

		

if {[string equal $language %symbol]} {
	<ref tag='%symbol table foreign text inserted in the grammar'/>
} else {
	lappend C [list foreign_text $language $no $ni $varnames $foreigntext]
}

		

			
lappend C [list if_bound A.$i]

		

			
lappend C [list on_failure A.1 A.2]

		

			
lappend C [list on_failure A.1]

		

			
lappend C [list put_constant [compileWAMConstant $f 0] A.$r]

		

			
lappend C [list put_list $tr]

		

			
lappend C [list put_structure [compileWAMConstant $f $n] $tr]

		

			
lappend C [list put_unsafe_value $map($f) A.$a]

		

			
lappend C [list put_value $map($f) A.$a]

		

			
lappend C [list put_variable $map($f) A.$a]

		

			
lappend C [list put_void A.$a]

		

			
lappend C [list set_constant $r]

		

			
lalappend C [list set_local_value $r]

		

			
lappend C [list set_value $r]

		

			
lappend C [list set_variable $r]

		

			
lappend C [list set_void 1]

		

			
lappend C [list trim_environment $le]

		

set flattenned {}
vprioq new work 0 [list 0 0 $term]
while {[vprioq dequeue work task est; set est]} {
	setp {out d list} $task
	if {[sym nested $list]} {set list [sym unnest $list]}
	if {$out} {
		setp {d n f} $list
		lappend flattenned $d $n $f
	} else {
		switch [sym first $list] {
			TERM {
				set functor [sym index $list 1]
				set terms [sym range $list 2 end]
				vprioq enqueuebefore work [list 1 0 [list $d [sym length $terms] $functor]]
				incr d
				while {![sym empty $terms]} {
					vprioq enqueuebefore work [list 0 $d [sym last $terms]]
					set terms [sym front $terms]
				}
			}
			VAR {
				lappend flattenned $d -1 [sym last $list]
			}
			NIL {
				lappend flattenned $d 0 %nil
			}
			LIST {
				set list [sym rest $list]
				vprioq enqueuebefore work [list 1 0 [list $d 2 LIST]]
				incr d
				while {![sym empty $terms]} {
					vprioq enqueuebefore work [list 0 $d [sym last $terms]]
					set terms [sym front $terms]
				}
			}
			ANTIUNIFY {
				set list [sym rest $list]
				vprioq enqueuebefore work [list 1 0 [list $d -2 ANTIUNIFY]]
				incr d
				while {![sym empty $terms]} {
					vprioq enqueuebefore work [list 0 $d [sym last $terms]]
					set terms [sym front $terms]
				}
			}
			FAILURE {
				set list [sym rest $list]
				vprioq enqueuebefore work [list 1 0 [list $d -3 FAILURE]]
				incr d
				while {![sym empty $terms]} {
					vprioq enqueuebefore work [list 0 $d [sym last $terms]]
					set terms [sym front $terms]
				}
			}
			SUCCESS {
				set list [sym rest $list]
				vprioq enqueuebefore work [list 1 0 [list $d -6 SUCCESS]]
				incr d
				while {![sym empty $terms]} {
					vprioq enqueuebefore work [list 0 $d [sym last $terms]]
					set terms [sym front $terms]
				}
			}
			FOREIGN {
				set code [sym last $list]
				set language [sym index $list 1]
				set list [sym range $list 2 end-1]
				set vars {}
				set d0 $d; incr d
				set m 0
				set n 0
				sym enum var $list {
					if {[string match +* $var]} {
						incr m
						set var [string range $var 1 end]
						lappend vars $var
						lappend flattenned $d -1 $var
					}
				}
				foreach var $list {
					if {[string match -* $var]} {
						incr n
						set var [string range $var 1 end]
						lappend vars $var
						lappend flattenned $d -1 $var
						lappend flattenned $d -5 $var
					}
				}
				lappend flattenned $d0 -4 [list $language $m $n $vars $code]
			}
		}
	}
}

		

set MZ {
	{initialise_memory C.0 J.0}
	{initialise_memory C.1 J.0}
	{initialise_constant C.0 %nil 0}
	{initialise_constant C.1 %undefined 0}
}
set F {%nil %undefined}

		

proc compileWAMConstant {f arity} {
	upvar 1 F F MZ MZ Y Y
	if {![info exists Y(c.$f/$arity)]} {
		set Y(c.$f/$arity) [llength $F]
		<Generated command: initialise_memory>
		<Generated command: initialise_constant>
		lappend F $f
	}
	if {$arity} {
		return [list C.$Y(c.$f/$arity).$f/$arity]
	} else {
		return [list C.$Y(c.$f/$arity).$f]
	}
}

		

			
gen term_vars $pn/[sym length $vars] $vars

		

			
gen term_production [sym first $head] [sym length $head]

		

			
lappend MZ [list initialise_constant C.[llength $F] [list $f] $arity]

		

			
lappend MZ [list initialise_memory C.[llength $F] J.$arity]

		

set Q {}

		

set C {fail pass}

		

array set Y {c.%nil/0 0 c.%undefined/0 0}

		

unset -nocomplain peuse
unset -nocomplain pecount
unset -nocomplain peclient
array set peuse {}
array set pecount {}
array set peclient {}
vprioq new work
set i 1
if {[sym length $head]} {vprioq enqueue work [list 1 $head]}
sym enum term $tail {
	vprioq enqueue work [list $i $term]
	incr i
}
while {[vprioq dequeue work task est; set est]} {
	setp {i list} $task
	if {[sym nested $list]} {set list [sym unnest $list]}
	switch [sym first $list] {
		VAR {
			set var [sym last $list]
			lappend peuse([list $var $i]) $i
			set pecount($var) 0
		}
		TERM {
			sym enum term [sym range $list 2 end] {vprioq enqueue work [list $i $term]}
		}
		LIST - ANTIUNIFY - FAILURE - SUCCESS {
			sym enum term [sym range $list 1 end] {vprioq enqueue work [list $i $term]}
		}
		FOREIGN {
			sym enum term [sym range $list 2 end-1] {
				set var [string range $term 1 end]
				lappend peuse([list $var $i]) $i
				set pecount($var) 0
			}
		}
	}
}
foreach v [array names peuse] {
	setp {v c} $v
	incr pecount($v)
	lappend peclient($v) $c
}
set permanent0 {}
foreach {v k} [array get pecount] {
	if {$k>1} {
		lappend permanent0 [list $v [lindex [lsort -integer $peclient($v)] end]]
	}
}
set permanent0 [lsort -integer -decreasing -index 1 $permanent0]


		

unset -nocomplain ulvar
array set ulvar {}
vprioq new work
if {[sym length $head]} {vprioq enqueue work $head}
sym enum term $tail {vprioq enqueue work $term}
while {[vprioq dequeue work list est; set est]} {
	if {[sym nested $list]} {set list [sym unnest $list]}
	switch [sym first $list] {
		VAR {
			set v [sym last $list]
			if {![info exists ulvar($v)]} {set ulvar($v) 0}
			incr ulvar($v)
		}
		TERM {
			sym enum term [sym range $list 2 end] {vprioq enqueue work $term}
		}
		LIST - ANTIUNIFY - FAILURE - SUCCESS {
			sym enum term [sym range $list 1 end] {vprioq enqueue work $term}
		}
		FOREIGN {
			sym enum term [sym range $list 2 end-1] {
				set v [string range $term 1 end]
				if {![info exists ulvar($v)]} {set ulvar($v) 0}
				incr ulvar($v)
			}
		}
	}
}
set useless {}
foreach {v k} [array get ulvar] {
	if {$k<2} {lappend useless $v}
}

		

foreach {procname aentry} [array get Y e.*] {
	set procname [lindex [split $procname .] 1]
	if {[string equal [lindex $C $aentry 0] nop]} {
		unset Y(a.$aentry); incr aentry; set Y(a.$aentry) $procname; set Y(e.$procname) $aentry
	}
	if {[string equal [lindex $C $aentry 0] try_me_else]} {
		<Index WAM/cow procedure>
	}
}

		

set arity [lindex $C $aentry 2]
if {![string length $arity]} {error null-arity}
array set procindex {V {} C {} L {} S {}}
for {set aclause $aentry} {$aclause!=0} {set aclause $anextclause} {
	if {[string equal [lindex $C $aclause 0] trust_me]} {
		set anextclause 0
	} else {
		set anextclause [lindex $C $aclause 1]
	}
	set asubclause $aclause; incr asubclause; set afirstget $asubclause
	while 1 {
		switch [lindex $C $afirstget 0] {
			allocate {
				incr afirstget
			}
			get_structure {
				lappend procindex(S) [lindex $C $afirstget 2] $asubclause
				break
			}
			get_constant {
				lappend procindex(C) [lindex $C $afirstget 2] $asubclause
				break
			}
			get_list {
				lappend procindex(L) $asubclause
				break
			}
			default {
				lappend procindex(V) $aclause
				break
			}
		}
	}
}
foreach x {C S} y {switch_on_constant switch_on_structure} {
	if {[llength $procindex($x)]==2} {
		set procindex($x) [thirdlevel [concat [lindex $procindex($x) 1] $procindex(V)]]
	} elseif {[llength $procindex($x)]==0} {
		set procindex($x) [thirdlevel $procindex(V)]
	} else {
		unset -nocomplain H
		foreach {symbol address} $procindex($x) {lappend H($symbol) $address}
		set switch {}
		foreach {symbol addresses} [array get H] {
			set addresses [thirdlevel [concat $addresses $procindex(V)]]
			lappend switch $symbol $addresses
		}
		set procindex($x) [llength $C]
		lappend C [list $y $switch]
	}
}
set procindex(L) [thirdlevel $procindex(L)]
set asegment [llength $C]
unset Y(a.$aentry); set Y(a.$asegment) $procname
set Y(e.$procname) $asegment
<Generated command: switch_on_term>

		

proc thirdlevel {addresses} {
	upvar 1 arity arity C C
	if {[llength $addresses]==1} {
		return $addresses
	} elseif {[llength $addresses]>1} {
		set aswitch [llength $C]
		for {set i 0; set n [llength $addresses]} {$i<$n} {incr i} {
			set a [lindex $addresses $i]
			if {$i==0} {
				<Generated command: try>
			} elseif {$i+1==$n} {
				<Generated command: trust>
			} else {
				<Generated command: retry>
			}
		}
		return $aswitch
	} else {
		return 0
	}
}

		

			
lappend C [list retry $a]

		

			
lappend C [list switch_on_term $aentry $procindex(C) $procindex(L) $procindex(S)]

		

			
lappend C [list trust $a]

		

			
lappend C [list try $a $arity]

		

foreach {e addr} [array get Y e.*] {
	set e [lindex [split $e .] 1]
	foreach ref $Y(f.$e) {
		lset C $ref 2 $addr
	}
}

		

	
set p 0
set sections {}
set section L.0
array set target {}
foreach instruction $C {
	switch [lindex $instruction 0] {
		switch_on_constant {
			foreach {c L} [lindex $instruction 1] {
				set target($L) 1
			}
		}
		call - execute {
			set target([lindex $instruction 2]) 1
		}
		try - retry - trust {
			set target([lindex $instruction 1]) 1
		}
	}
}
set o 0
foreach instruction $C {
	if {[info exists target($p)] && [llength $section]>1} {
		lappend section [list continue_at L.$p]
		lappend sections $section
		set section L.$p
	}
	incr o
	set p1 [expr {$p+1}]
	if {[info exists Y(a.$p)]} {
		lappend section [list entry_point $Y(a.$p)]
	}
	switch [lindex $instruction 0] {
		call {
			set instruction [
				concat call [list L.[lindex $instruction 2].[lindex $instruction 1]] [lrange $instruction 3 end] R.$p1
			]
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		retry - try {
			lset instruction 1 L.[lindex $instruction 1]
			lappend instruction R.$p1
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		execute {
			set instruction [
				concat execute [list L.[lindex $instruction 2].[lindex $instruction 1]] [lrange $instruction 3 end]
			]
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		trust {
			lset instruction 1 L.[lindex $instruction 1]
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		fail - pass - proceed {
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		switch_on_constant - switch_on_structure {
			set op [lindex $instruction 0]
			set hash {}
			foreach {c l} [lindex $instruction 1] {
				lappend hash $c L.$l
			}
			set instruction [list $op [list $hash]]
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		switch_on_term {
			setp {op v c l s} $instruction
			set instruction [list $op L.$v L.$c L.$l L.$v]
			lappend section $instruction
			lappend sections $section
			set section L.$p1
		}
		try_me_else - retry_me_else {
			lset instruction 1 R.[lindex $instruction 1]
			lappend section $instruction
		}
		default {
			lappend section $instruction
		}
	}
	set p $p1
}
set code {}
foreach section $sections {
	set section [setp name $section]
	lappend code [list BEGIN section $name]
	foreach instruction $section {
		lappend code $instruction
	}
	lappend code END
}

		

gen BEGIN attribute_wam [$grammar name:]
	gen BEGIN wam_initialisation
		gen initialise_register B S.0
		gen initialise_register BO S.0
		gen initialise_register CP L.1
		gen initialise_register E S.1
		gen initialise_register H H.0
		gen initialise_register HB H.0
		gen initialise_register mode READ
		gen initialise_register P L.0
		gen initialise_register S H.0
		gen initialise_register TR T.0
		foreach command $MZ {
			eval gen $command
		}
	gen END
	gen BEGIN eval_loop
		foreach instruction $code {gen $instruction}
	gen END
gen END

		

		
proc displayAttribute {parsed} {
	if {[sym nested $parsed]} {set parsed [sym unnest $parsed]}
#puts [string repeat . [info level]]$parsed
	switch [sym card $parsed] {
		0 {return "{}"}
		1 {;}
		default {
			set U ""; set sep ""
			sym each term $parsed {append U $sep[displayAttribute $term]; set sep "; "}
			return $U
		}
	}
	switch [sym first $parsed] {
		%query {
			return "[sym index $parsed 1] ?-[displayAttribute [sym range $parsed 2 end]]."
		}
		TERM {
			set args {}
			set r [sym index $parsed 1]
			sym enum arg [sym range $parsed 2 end] {
				append args ",[displayAttribute $arg]"
			}
			return <$r$args>
		}
		VAR {
			return [sym last $parsed]
		}
		LIST {
			set a [sym index $parsed 1]
			set b [sym unnest [sym index $parsed 2]]
			set a [displayAttribute $a]
			while 1 {
				switch [sym first $b] {
					LIST {
						set x [sym index $b 1]
						set b [sym unnest [sym index $b 2]]
						append a ,[displayAttribute $x]
					}
					NIL {
						set r \[$a\]
						break
					}
					default {
						set r \[$a|[displayAttribute $b]\]
						break
					}
				}
			}
			return $r
		}
		NIL {
			return {[]}
		}
		ANTIUNIFY {
			set a [sym index $parsed 1]
			set b [sym index $parsed 2]
			return "<%antiunify%,[displayAttribute $a],[displayAttribute $b]>"
		}
		FAILURE {
			return "%failure-recovery%"
		}
		SUCCESS {
			return "%success%"
		}
		FOREIGN {
			return "<%foreign%,[sym range $parsed 1 end]>"
		}
		default {
			set r ""; set sep1 ""; set sep2 " :- "
			sym enum predicate $parsed {
				if {[string equal $predicate $parsed]} {error HANG}
				append r "$sep1[displayAttribute $predicate]"
				set sep1 $sep2
				set sep2 ", "
			}
			return $r.
		}
	}
}