1# -*- tcl -*- 2# 3# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 4# Parser Generator / Frontend - Read halfbaked PEG container. 5 6# ### ### ### ######### ######### ######### 7## Requisites 8 9namespace eval ::page::parse::peghb { 10 variable fixup {} 11 variable definitions 12} 13 14# ### ### ### ######### ######### ######### 15## API 16 17proc ::page::parse::peghb {halfbaked t} { 18 variable peghb::fixup 19 variable peghb::definitions 20 array set definitions {} 21 22 set fixup {} 23 24 interp create -safe sb 25 # Should remove everything. 26 interp alias sb Start {} ::page::parse::peghb::Start $t 27 interp alias sb Define {} ::page::parse::peghb::Define $t 28 interp eval sb $halfbaked 29 interp delete sb 30 31 array set undefined {} 32 array set users {} 33 foreach {n sym} $fixup { 34 if {[info exists definitions($sym)]} { 35 set def $definitions($sym) 36 $t set $n def $def 37 lappend users($def) $n 38 } else { 39 lappend undefined($sym) $n 40 } 41 } 42 43 foreach def [array names users] { 44 $t set $def users $users($def) 45 } 46 47 $t set root definitions [array get definitions] 48 $t set root undefined [array get undefined] 49 $t set root symbol <StartExpression> 50 $t set root name <HalfBaked> 51 52 return 53} 54 55# ### ### ### ######### ######### ######### 56## Internal. Helpers 57 58proc ::page::parse::peghb::Start {t pe} { 59 variable fixup 60 $t set root start [treeOf $t root $pe fixup] 61 return 62} 63 64proc ::page::parse::peghb::Define {t mode sym pe} { 65 variable fixup 66 variable definitions 67 68 set def [$t insert root end] 69 70 $t set $def users {} 71 $t set $def symbol $sym 72 $t set $def label $sym 73 $t set $def mode $mode 74 75 treeOf $t $def $pe fixup 76 77 set definitions($sym) $def 78 return 79} 80 81proc ::page::parse::peghb::treeOf {t root pe fv} { 82 upvar 1 $fv fixup 83 84 set n [$t insert $root end] 85 set op [lindex $pe 0] 86 $t set $n op $op 87 88 if {$op eq "t"} { 89 $t set $n char [lindex $pe 1] 90 91 } elseif {$op eq ".."} { 92 $t set $n begin [lindex $pe 1] 93 $t set $n end [lindex $pe 2] 94 95 } elseif {$op eq "n"} { 96 97 set sym [lindex $pe 1] 98 $t set $n sym $sym 99 $t set $n def "" 100 101 lappend fixup $n $sym 102 } else { 103 foreach sub [lrange $pe 1 end] { 104 treeOf $t $n $sub fixup 105 } 106 } 107 return $n 108} 109 110# ### ### ### ######### ######### ######### 111## Internal. Strings. 112 113namespace eval ::page::parse::peghb {} 114 115# ### ### ### ######### ######### ######### 116## Ready 117 118package provide page::parse::peghb 0.1 119