I received this mail from Frans Houewlling which he said I may forward
here.
----- Forwarded message from Frans Houweling <fhouwel...@email.it> -----
Date: Mon, 10 Dec 2018 22:49:57 +0100
From: Frans Houweling <fhouwel...@email.it>
To: John Darrington <j...@darrington.wattle.id.au>
Subject: Macros
User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101
Thunderbird/60.3.3
Hi John,
a few years ago I suggested a little program could be made that would read an
SPSS syntax file with macro definitions and calls, and produce an expanded
syntax file.
Well, I have been doing my best to get such a little program working, but I'm
afraid more skills than mine would be needed. I left it lying around promising
myself to sooner or later turn it into a reference implementation (ehm) but
I'm afraid I'm getting too old for that.
So here is the tcl script I came up with. I add a syntax file with one of my
favorite macros as example input. Do with it what you like - no offense taken
- but please do try to get macros implemented somehow.
If I can contribute to pspp in some more feasible way (I know dutch and
italian, for example) please let me know.
Thanks for your work
frans//
#!/usr/bin/env tclsh
set MAXFILESIZE 1000000
###
# Minimal lexer.
# Call lexer::init with the text buffer to parse, and lexer::destroy to free
the memory.
# You may have more than one instance running.
#
namespace eval ::lexer {
variable lexerID 0
variable lexers
array set lexers {}
}
# Makes a local copy of the text buffer and maintains an index into it.
# Returns an ID for the lexer instance.
#
proc lexer::init {bufferName {index 0}} {
upvar $bufferName buf
variable lexerID
variable lexers
incr lexerID
set lexers($lexerID:buffer) $buf
# Try to make end of line handling easier:
regsub -all {\r\n} $lexers($lexerID:buffer) "\n" lexers($lexerID:buffer)
regsub -all {\r} $lexers($lexerID:buffer) "\n" lexers($lexerID:buffer)
regsub -all {( |\t)+\n} $lexers($lexerID:buffer) "\n"
lexers($lexerID:buffer)
set lexers($lexerID:buffer) [string trim $lexers($lexerID:buffer)]
set lexers($lexerID:ndx) $index
set lexers($lexerID:cmdEnd) 0
set lexers($lexerID:cmdBuf) {} ;# gets built up by getSym ..
set lexers($lexerID:thisCmd) {} ;# .. and flushed here when the
terminating dot is found
return $lexerID
}
proc lexer::destroy {lexerID} {
variable lexers
array unset lexers $lexerID:*
return
}
# Get next character and increment index
#
proc lexer::getChar {lexerID} {
variable lexers
if {$lexers($lexerID:ndx) >= [string length $lexers($lexerID:buffer)]} {
return {}
}
set c [string index $lexers($lexerID:buffer) $lexers($lexerID:ndx)]
incr lexers($lexerID:ndx)
return $c
}
# Decrement index
#
proc lexer::ungetChar {lexerID} {
variable lexers
if {$lexers($lexerID:ndx) <= 0} {
error "Beginning of file"
}
incr lexers($lexerID:ndx) -1
return
}
# Get next character but leave index alone
#
proc lexer::peepChar {lexerID {ndx {}}} {
variable lexers
if {![string length $ndx]} {
set ndx $lexers($lexerID:ndx)
}
if {$ndx >= [string length $lexers($lexerID:buffer)]} {
return {}
}
return [string index $lexers($lexerID:buffer) $ndx]
}
proc lexer::charType {lexerID c} {
variable lexers
if {$c eq "\n"} {
set type endline
} elseif {[regexp {\s} $c]} {
set type white
} elseif {$c eq "'" || $c eq "\""} {
set type quote
} elseif {$c eq "/" && [peepChar $lexerID] eq "*"} {
set type comment
} elseif {[regexp {[A-Za-z0-9_#@!\.]} $c]} {
set type wordchar
} else {
set type other
}
return $type
}
# Are we at the end of a line?
#
proc ::lexer::eol {lexerID {ndx {}}} {
variable lexers
if {![string length $ndx]} {
set ndx $lexers($lexerID:ndx)
}
set nextChar [peepChar $lexerID $ndx]
return [expr {![string length $nextChar] || $nextChar eq "\n"}]
}
# Get a symbol. Returns quoted strings and /*-style comments as single symbols.
#
proc lexer::getSym {lexerID} {
variable lexers
if {[set c [getChar $lexerID]] == {}} { ;# eof
set lexers($lexerID:thisCmd) $lexers($lexerID:cmdBuf)
set lexers($lexerID:cmdEnd) 1
set lexers($lexerID:cmdBuf) {}
return {}
}
set lexers($lexerID:cmdEnd) 0
set buf $c
set tokenType [charType $lexerID $c]
set quoteChar {}
if {$tokenType eq "quote"} {
set quoteChar $c
}
while {[set c [getChar $lexerID]] != {}} {
set newType [charType $lexerID $c]
if {$tokenType eq "comment"} {
if {$c eq "*" && [peepChar $lexerID] eq "/"} {
getChar $lexerID
append buf "*/"
append lexers($lexerID:cmdBuf) $buf
return $buf
}
append buf $c
continue
}
if {$tokenType eq "quote"} {
if {$c eq $quoteChar && [peepChar $lexerID] ne $quoteChar} {
append buf $c
append lexers($lexerID:cmdBuf) $buf
return $buf
}
append buf $c
continue
}
if {$c eq "."} {
if {[eol $lexerID]} {
append lexers($lexerID:cmdBuf) $buf
ungetChar $lexerID
return $buf ;# because we want the dot to be token by itself
} else {
append buf $c
continue
}
}
if {$c eq "\n" && $buf eq "."} {
append buf $c
append lexers($lexerID:cmdBuf) $buf
set lexers($lexerID:thisCmd) $lexers($lexerID:cmdBuf)
set lexers($lexerID:cmdBuf) {}
set lexers($lexerID:cmdEnd) 1
return $buf
}
if {$newType ne $tokenType || $newType eq "other"} {
ungetChar $lexerID
append lexers($lexerID:cmdBuf) $buf
return $buf
}
append buf $c
}
# eof
set lexers($lexerID:thisCmd) $lexers($lexerID:cmdBuf)
append lexers($lexerID:thisCmd) $buf
set lexers($lexerID:cmdBuf) {}
set lexers($lexerID:cmdEnd) 1
return $buf
}
# Get next symbol skipping whitespace
#
proc lexer::getToken {lexerID} {
variable lexers
while {[string trim [set sym [getSym $lexerID]]] eq ""} {
if {$sym == {}} break
}
return $sym
}
# all syms up to - and included - the dot.
#
proc lexer::getCmd {lexerID} {
variable lexers
while {[getSym $lexerID] != {} && !$lexers($lexerID:cmdEnd)} {
continue
}
return [string trim $lexers($lexerID:thisCmd)]
}
# Set index
#
proc lexer::newIndex {lexerID index} {
variable lexers
set lexers($lexerID:ndx) $index
return
}
# Query index
#
proc lexer::index {lexerID} {
variable lexers
return $lexers($lexerID:ndx)
}
# End of command?
#
proc lexer::eoc {lexerID} {
variable lexers
return $lexers($lexerID:cmdEnd)
}
# Get contents of command buffer built up so far
#
proc lexer::commandBuffer {lexerID} {
variable lexers
return $lexers($lexerID:cmdBuf)
}
# Get (piece of) local copy of text buffer
#
proc lexer::rawBuffer {lexerID {start {}} {end end}} {
variable lexers
if {![string length $start]} {
set start $lexers($lexerID:ndx)
}
return [string range $lexers($lexerID:buffer) $start $end]
}
# Searches and returns index of matching element
# Examples left & right: "(" & ")", "!DO" & "!DOEND"
#
proc lexer::matchDo {lexerID left right} {
variable lexers
set currentNdx $lexers($lexerID:ndx)
set depth 1
while {$depth > 0 && [set sym [getSym $lexerID]] != {}} {
if {[string equal -nocase $sym $left]} {
incr depth
} elseif {[string equal -nocase $sym $right]} {
incr depth -1
}
}
set ndx $lexers($lexerID:ndx)
# restore
set lexers($lexerID:ndx) $currentNdx
if {$depth != 0} {
return -1
}
set endNdx [expr {$ndx - [string length $right]}]
return $endNdx
}
# Insert txt in textbuffer and adjust the index if necessary
#
proc lexer::insert {lexerID txt {ndx {}}} {
variable lexers
regsub -all {\r\n} $txt "\n" txt
regsub -all {\r} $txt "\n" txt
regsub -all {( |\t)+\n} $txt "\n" txt
if {![string length $ndx]} {
set ndx $lexers($lexerID:ndx)
}
set buf [string range $lexers($lexerID:buffer) 0 [expr {$ndx - 1}]]
append buf $txt [string range $lexers($lexerID:buffer) $ndx end]
set lexers($lexerID:buffer) $buf
if {$ndx > $lexers($lexerID:ndx)} {
set lexers($lexerID:ndx) [expr {$lexers($lexerID:ndx) + [string length
$txt]}]
}
return {}
}
###
# Set up definition of a single macro argument
#
proc defineArg {argTxt position macroName} {
global defined
set argTxt [string toupper [string trim $argTxt]]
if {![regexp {^([!@#\$_A-Z][\._\$#@A-Z0-9]*)\s*=?\s*(.*)$} $argTxt ->
argName assoc]} {
error "Definition of $macroName: argument #$position: invalid syntax"
}
set argName [string toupper $argName]
set assoc [string trim $assoc]
if {[regexp {^!POS} $argName]} {
set defined($macroName:args:position:$position) $position
set argName $position
} else {
set defined($macroName:args:position:$position) $argName
}
if {[regexp {!TOK[ENS]*\s*\(([^\)]+)\s*\)} $assoc -> numTokens]} {
set defined($macroName:args:$argName:type) "!TOKENS"
set defined($macroName:args:$argName:tokens) $numTokens
} elseif {[regexp {!CHA[REND]*\s*\(\s*['\"](\S)['\"]\s*\)} $assoc ->
charend]} {
set defined($macroName:args:$argName:type) "!CHAREND"
set defined($macroName:args:$argName:charend) $charend
} elseif {[regexp
{!ENC[LOSE]*\s*\(\s*(?:\"|')(.)(?:\"|')\s*,\s*(?:\"|')(.)(?:\"|')\s*\)} $assoc
-> charStart charEnd]} {
set defined($macroName:args:$argName:type) "!ENCLOSE"
set defined($macroName:args:$argName:enclose:0) $charStart
set defined($macroName:args:$argName:enclose:1) $charEnd
} elseif {[regexp {!CMD[END]*} $assoc]} {
set defined($macroName:args:$argName:type) "!CMDEND"
} else {
error "Macro $macroName argument $argName: missing one of !TOKENS,
!CHAREND, !ENCLOSE, !CMDEND"
}
if {[regexp {!DEF[AULT]*\s*\(([^\)]+)\s*\)} $assoc -> defVal]} {
set defined($macroName:args:$argName:default) [unQuote $defVal]
}
if {[regexp {!NOE[XPAND]*} $assoc]} {
set defined($macroName:args:$argName:noexpand) 1
}
return
}
# Set up macro definition. A global array holds the definitions.
#
proc defineMacro {lexerID} {
global defined
set macroName [string toupper [::lexer::getToken $lexerID]]
set outBuf "DEFINE $macroName"
set ndx [::lexer::index $lexerID]
if {[set endNdx [::lexer::matchDo $lexerID DEFINE !ENDDEFINE]] == -1} {
error "Macro $macroName: missing !ENDDEFINE"
}
set macroBuf [string trim [::lexer::rawBuffer $lexerID $ndx [expr {$endNdx
- 1}]]]
append outBuf $macroBuf
# first char should now be left paren
if {[::lexer::getToken $lexerID] != "("} {
error "Macro $macroName: missing \"(\""
}
if {[set riteNdx [::lexer::matchDo $lexerID "(" ")"]] == -1} {
error "Macro $macroName: missing \")\""
}
set numArgs 0
set argBuf {}
if {[::lexer::index $lexerID] == $riteNdx} { ;# the () case
::lexer::getSym $lexerID
} else {
while {[::lexer::index $lexerID] < $riteNdx} {
set sym [::lexer::getSym $lexerID]
if {[::lexer::index $lexerID] == $riteNdx || $sym eq "/"} {
if {$sym ne "/"} {
append argBuf $sym
::lexer::getSym $lexerID
}
incr numArgs
defineArg $argBuf $numArgs $macroName
set argBuf {}
} else {
append argBuf $sym
}
}
}
set defined($macroName:numArgs) $numArgs
set defined($macroName:body) [string trim [::lexer::rawBuffer $lexerID {}
[expr {$endNdx - 1}]]]
set defined($macroName:expandable) 1
# reposition ndx
::lexer::newIndex $lexerID $endNdx
set tok [::lexer::getToken $lexerID] ;# !ENDDEFINE
if {$defined($macroName:numArgs)} {
append outBuf "\n$tok"
} else {
append outBuf " $tok"
}
set tok [::lexer::getToken $lexerID] ;# end of command
append outBuf " $tok"
return $outBuf
}
proc unQuote {txt} {
return [string trim $txt {\'\"}]
}
# We want to allow for INSERT FILE = !LIB + "mymacro.sps".
# and the like - therefore must try to expand macros straight away.
# LIMITATIONS: arguments to INSERT FILE are ignored.
#
proc insertFile {lexerID} {
global defined
global MAXFILESIZE
set token [::lexer::getToken $lexerID]
if {[string toupper $token] eq "FILE"} {
set token [::lexer::getToken $lexerID]
}
if {$token eq "="} {
set token [::lexer::getToken $lexerID]
}
set nameBuf {}
while {![::lexer::eoc $lexerID]} {
if {[info exists defined([string toupper $token]:numArgs)]} {
set token [string toupper $token]
append nameBuf [string trim [expandMacro $token $lexerID]]
set expansion 1
} else {
append nameBuf $token
}
set token [::lexer::getSym $lexerID]
if {[expr {[string toupper $token] in [list CD ERROR SYNTAX
ENCODING]}]} {
::lexer::getCmd $lexerID
break
}
}
set nameBuf [string trim $nameBuf]
regsub -all {(\"|')\s*\+\s*(\"|')} $nameBuf {} nameBuf
if {![regexp {^(?:\"|')(.*)(?:\"|')$} $nameBuf -> fileName]} {
error "ERROR: expected quoted name, got $nameBuf"
}
if {![file exists $fileName]} {
error "ERROR: file does not exist: $fileName"
}
if {![file size $fileName] > $MAXFILESIZE} {
error "ERROR: file too big: $fileName"
}
set h [open $fileName r]
set buf [read $h]
close $h
set txt "\n"
append txt $buf "\n"
::lexer::insert $lexerID $txt
return {}
}
####### macro functions ###
# Each SPSS macro function has an equivalent with the bang replaced by
underscore.
proc _AND {macroName lexerID} {
return " && "
}
proc _BLANKS {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !BLANKS: expected \"(\", found \"$lParen\""
}
if {[set endNdx [::lexer::matchDo $lexerID "(" ")"]] == -1} {
error "ERROR !BLANKS: missing closing \")\""
}
set valuIn [::lexer::getToken $lexerID]
set valu [expandToken $macroName $valuIn $lexerID]
if {![regexp {^[0-9]+$} $valu]} {
error "ERROR !BLANKS: expected number, found \"$valu\""
}
::lexer::newIndex $lexerID $endNdx
::lexer::getToken $lexerID ;# closing paren
return [string repeat " " $valu]
}
proc _CONCAT {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !CONCAT: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set valuL [list]
while {[::lexer::index $lexerID] < $endNdx} {
set valu [unQuote [::lexer::getToken $lexerID]]
lappend valuL [expandToken $macroName $valu $lexerID]
if {[set comma [::lexer::getToken $lexerID]] eq ")"} break
if {$comma eq ","} continue
error "ERROR !CONCAT: expected \",\" or \")\", found \"$comma\""
}
return [join $valuL {}]
}
proc _DO {macroName lexerID} {
global defined
if {[set lastNdx [::lexer::matchDo $lexerID !DO !DOEND]] == -1} {
error "ERROR: no matching !DOEND"
}
set standinVar [string toupper [::lexer::getToken $lexerID]]
if {![regexp {^!(.*)$} $standinVar -> bangStandIn]} {
error "ERROR $macroName !DO: expected banged stand-in var, found
\"$standinVar\""
}
if {[set inVal [::lexer::getToken $lexerID]] ne "!IN"} {
error "ERROR $macroName !DO: expected \"!IN\", found \"$inVal\""
}
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR $macroName !DO: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set loopBuf [::lexer::rawBuffer $lexerID {} [expr {$endNdx - 1}]]
set loopNdx 0
set loopL [list]
set loopID [::lexer::init loopBuf]
while {[set tok [::lexer::getToken $loopID]] != {}} {
lappend loopL {*}[expandToken $macroName $tok $loopID]
}
::lexer::destroy $loopID
set loopBodyStamp [string trim [::lexer::rawBuffer $lexerID [expr {$endNdx
+ 1}] [expr {$lastNdx - 1}]]]
set outBuf {}
foreach loopVal $loopL {
set bodyID [::lexer::init loopBodyStamp]
set defined($macroName:args:$bangStandIn:subst) $loopVal
while {[set sym [::lexer::getSym $bodyID]] != {}} {
set sym [expandToken $macroName $sym $bodyID]
append outBuf $sym
}
append outBuf "\n"
::lexer::destroy $bodyID
}
::lexer::newIndex $lexerID $lastNdx
if {[set tok [::lexer::getToken $lexerID]] ne "!DOEND"} {
error "ERROR !DO: expected \"!DOEND\", found: \"$tok\""
}
return $outBuf
}
proc _DOEND {macroName lexerID} {
return {}
}
proc _EQ {macroName lexerID} {
return " eq "
}
proc _GE {macroName lexerID} {
return " >= "
}
proc _GT {macroName lexerID} {
return " > "
}
proc _HEAD {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !HEAD: expected \"(\", found \"$lParen\""
}
if {[set endNdx [::lexer::matchDo $lexerID "(" ")"]] == -1} {
error "ERROR !HEAD: missing closing \")\""
}
set valu [lindex [expandToken $macroName [::lexer::getToken $lexerID]
$lexerID] 0]
::lexer::newIndex $lexerID $endNdx
::lexer::getToken $lexerID ;# closing paren
return $valu
}
# Translate condition to Tcl and eval in safe interpreter.
#
proc _IF {macroName lexerID} {
global ifInterp
if {[set lastNdx [::lexer::matchDo $lexerID !IF !IFEND]] == -1} {
error "ERROR: no matching !IFEND"
}
set elseNdx [::lexer::matchDo $lexerID !IF !ELSE]
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR $macroName !IF: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set condBuf [::lexer::rawBuffer $lexerID {} [expr {$endNdx - 1}]]
set condID [::lexer::init condBuf]
set ifBuf {}
while {[set tok [::lexer::getToken $condID]] != {}} {
# require = false for lazy eval of condition
if {[set tokenType [::lexer::charType $condID [string range $tok 0 0]]]
ne "quote" && $tokenType ne "comment"} {
set tok [string toupper $tok]
}
append ifBuf [expandToken $macroName $tok $condID 0]
}
::lexer::destroy $condID
set outBuf {}
if {$elseNdx == -1} {
set yesBodyStamp [string trim [::lexer::rawBuffer $lexerID [expr
{$endNdx + 1}] [expr {$lastNdx - 1}]]]
set noBodyStamp {}
} else {
set yesBodyStamp [string trim [::lexer::rawBuffer $lexerID [expr
{$endNdx + 1}] [expr {$elseNdx - 1}]]]
set noBodyStamp [string trim [::lexer::rawBuffer $lexerID [expr
{$elseNdx + 6}] [expr {$lastNdx - 1}]]]
}
set condNdx 0
set yesID [::lexer::init yesBodyStamp]
if {[set then [::lexer::getToken $yesID]] ne "!THEN"} {
error "ERROR $macroName !IF: expected !THEN, found \"$then\""
}
set yesBodyStamp [string trim [string range $yesBodyStamp [::lexer::index
$yesID] end]]
::lexer::destroy $yesID
set cond [subst -nocommands -nobackslashes $ifBuf]
set bool [$ifInterp eval [list expr $cond]]
if {$bool} {
set outBuf $yesBodyStamp
} else {
set outBuf $noBodyStamp
}
::lexer::newIndex $lexerID $lastNdx
if {[set tok [::lexer::getToken $lexerID]] ne "!IFEND"} {
error "ERROR $macroName !IF: expected !IFEND found: \"$tok\""
}
set retBuf {}
set outID [::lexer::init outBuf]
while {1} {
while {[string trim [set sym [::lexer::getSym $outID]]] eq ""} {
if {$sym == {}} break
append retBuf $sym
}
if {$sym == {}} break
append retBuf [expandToken $macroName $sym $outID]
}
::lexer::destroy $outID
return $retBuf
}
proc _LENGTH {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !LENGTH: expected \"(\", found \"$lParen\""
}
if {[set endNdx [::lexer::matchDo $lexerID "(" ")"]] == -1} {
error "ERROR !LENGTH: missing closing \")\""
}
set valuIn [::lexer::getToken $lexerID]
set valu [expandToken $macroName $valuIn $lexerID]
::lexer::newIndex $lexerID $endNdx
::lexer::getToken $lexerID ;# closing paren
return [string length $valu]
}
proc _LE {macroName lexerID} {
return " <= "
}
proc _LET {macroName lexerID} {
global defined
set defVar [string toupper [::lexer::getToken $lexerID]]
if {![regexp {^!(.*)$} $defVar -> bangDef]} {
error "ERROR !LET: expected banged var, found \"$defVar\""
}
if {[set equals [::lexer::getToken $lexerID]] ne "="} {
error "ERROR !LET: expected \"=\", found \"$equals\""
}
set valuIn [string toupper [::lexer::getToken $lexerID]]
set valu [expandToken $macroName $valuIn $lexerID]
set defined($macroName:args:$bangDef:subst) $valu
return {}
}
proc _LT {macroName lexerID} {
return " < "
}
proc _NE {macroName lexerID} {
return " ne "
}
proc _OR {macroName lexerID} {
return " || "
}
proc _QUOTE {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !UNQUOTE: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set valu [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
if {[set rParen [::lexer::getToken $lexerID]] ne ")"} {
error "ERROR !UNQUOTE: expected \")\", found \"$rParen\""
}
return \"[string trim $valu \"]\"
}
proc _SUBSTR {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !SUBSTR: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set valu [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
if {[set comma [::lexer::getToken $lexerID]] ne ","} {
error "ERROR !SUBSTR: expected \",\", found \"$comma\""
}
set start [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
if {![string is integer -strict $start]} {
error "ERROR !SUBSTR: expected start position, found \"$start\""
}
if {[set comma [::lexer::getToken $lexerID]] ne ","} {
error "ERROR !SUBSTR: expected \",\", found \"$comma\""
}
set len [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
if {![string is integer -strict $len]} {
error "ERROR !SUBSTR: expected length, found \"$len\""
}
if {[set rParen [::lexer::getToken $lexerID]] ne ")"} {
error "ERROR !LENGTH: expected \")\", found \"$rParen\""
}
return \"[string range $valu [expr {$start -1}] [expr {$start - 1 + $len -
1}]]\"
}
proc _TAIL {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !TAIL: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set headTokL [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
set headVal [lindex $headTokL 0] ;# = HEAD
set retLis [lrange $headTokL 1 end]
while {[set valu [::lexer::getToken $lexerID]] != {} && [::lexer::index
$lexerID] < $endNdx} {
lappend retLis {*}[expandToken $macroName $valu $lexerID]
}
return $retLis
}
proc _UNQUOTE {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !UNQUOTE: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set valu [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
if {[set rParen [::lexer::getToken $lexerID]] ne ")"} {
error "ERROR !UNQUOTE: expected \")\", found \"$rParen\""
}
return [string trim $valu \"]
}
proc _UPCAS {macroName lexerID} {
if {[set lParen [::lexer::getToken $lexerID]] ne "("} {
error "ERROR !LENGTH: expected \"(\", found \"$lParen\""
}
set endNdx [::lexer::matchDo $lexerID "(" ")"]
set valu [expandToken $macroName [::lexer::getToken $lexerID] $lexerID]
if {[set rParen [::lexer::getToken $lexerID]] ne ")"} {
error "ERROR !LENGTH: expected \")\", found \"$rParen\""
}
return [string toupper $valu]
}
##### end macro functions ###
# Expand a single token
#
proc expandToken {macroName token lexerID {require 0}} {
global defined
if {[regexp {^!(.*)$} $token -> bangedSym]} {
set bangedSym [string toupper $bangedSym]
if {[info exists defined($macroName:args:$bangedSym:subst)]} {
set valu $defined($macroName:args:$bangedSym:subst)
} elseif {[llength [info procs _$bangedSym]]} {
set valu [_$bangedSym $macroName $lexerID]
} elseif {$require} {
error "ERROR in macro call $macroName: \"$token\" unknown"
} else { ;# in conditions token may be undefined
set valu 0
}
} else {
set valu $token
}
return $valu
}
# Expand a syntax macro
#
proc expandMacro {macroName lexerID} {
global defined
if {![info exists defined($macroName:body)]} {
error "Macro $macroName not found"
}
if {!$defined($macroName:expandable)} {
return {}
}
set currentNdx [::lexer::index $lexerID]
set localBuf [::lexer::getCmd $lexerID]
if {$defined($macroName:numArgs) == 0} {
::lexer::newIndex $lexerID $currentNdx
return $defined($macroName:body)
}
set defined($macroName:expandable) 0
set localID [::lexer::init localBuf]
for {set argNdx 1} {$argNdx <= $defined($macroName:numArgs)} {incr argNdx} {
set argName $defined($macroName:args:position:$argNdx)
set defined($macroName:args:$argName:subst) {}
set substList [list]
set type $defined($macroName:args:$argName:type)
if {$argName ne $argNdx} {
::lexer::newIndex $localID 0
while {[set token [::lexer::getToken $localID]] != {} && [string
toupper $token] ne $argName} continue
if {[string toupper $token] ne $argName} {
if {![info exists defined($macroName:args:$argName:default)]} {
error "ERROR macro call $macroName: argument $argName
missing with no default"
} else {
set defined($macroName:args:$argName:subst)
$defined($macroName:args:$argName:default)
}
continue
}
if {[::lexer::getToken $localID] ne "="} {
error "ERROR macro call $macroName argument $argName: expected
\"=\""
}
} ;# else (!POS) ready.
if {$type eq "!TOKENS"} {
for {set i 0} {$i < $defined($macroName:args:$argName:tokens)}
{incr i} {
set token [::lexer::getToken $localID]
if {![string length $token] || $token eq "/" || $token eq "."} {
if {$i > 0} {
error "ERROR macro call $macroName argument $argName:
too few tokens"
}
break
}
lappend substList $token
}
} elseif {$type eq "!CHAREND"} {
set i 0
while {[string length [set token [::lexer::getToken $localID]]] &&
$token ne $defined($macroName:args:$argName:charend)} {
incr i
lappend substList [string toupper $token]
}
if {$token ne $defined($macroName:args:$argName:charend)} {
if {$i > 0} {
error "ERROR macro call $macroName argument $argName:
missing CHAREND (\"$defined($macroName:args:$argName:charend)\")"
}
}
} elseif {$type eq "!ENCLOSE"} {
if {[set token [::lexer::getToken $localID]] ne
$defined($macroName:args:$argName:enclose:0)} {
error "ERROR macro call $macroName argument $argName: missing
left enclose char (\"$defined($macroName:args:$argName:enclose:0)\")"
}
set i 0
while {[string length [set token [::lexer::getToken $localID]]] &&
$token ne $defined($macroName:args:$argName:enclose:1)} {
incr i
lappend substList $token
}
if {$token ne $defined($macroName:args:$argName:enclose:1)} {
if {$i > 0} {
error "ERROR macro call $macroName argument $argName:
missing right enclose char (\"$defined($macroName:args:$argName:enclose:1)\")"
}
}
} elseif {$type eq "!CMDEND"} {
set i 0
while {[string length [set token [::lexer::getToken $localID]]] &&
$token ne "."} {
incr i
lappend substList $token
}
if {$token ne "."} {
if {$i > 0} {
error "ERROR macro call $macroName argument $argName:
missing command terminator"
}
}
} else {
error "ERROR macro $macroName: unknown type \"$type\""
}
if {![llength $substList]} {
if {![info exists defined($macroName:args:$argName:default)]} {
error "ERROR macro call $macroName: argument $argName missing
with no default"
} else {
set defined($macroName:args:$argName:subst)
$defined($macroName:args:$argName:default)
}
} else {
set defined($macroName:args:$argName:subst) [join $substList " "]
}
}
::lexer::destroy $localID
set body $defined($macroName:body)
set bodyID [::lexer::init body]
set nwBody {}
while {[set sym [::lexer::getSym $bodyID]] != {}} {
if {[regexp {^!(.*)$} $sym -> bangedSym]} {
set bangedSym [string toupper $bangedSym]
if {[info exists defined($macroName:args:$bangedSym:subst)]} {
append nwBody $defined($macroName:args:$bangedSym:subst)
} elseif {[llength [info procs _$bangedSym]]} {
append nwBody [_$bangedSym $macroName $bodyID]
} else {
append nwBody $sym
}
} else {
append nwBody $sym
}
}
::lexer::destroy $bodyID
set defined($macroName:expandable) 1
return $nwBody
}
# Get the contents of a syntax file
#
proc loadSyntax {syntaxName} {
global MAXFILESIZE
if {[file size $syntaxName] > $MAXFILESIZE} {
error "Input file size exceeds limit of $MAXFILESIZE bytes"
}
set h [open $syntaxName r]
set buf [read $h]
close $h
return $buf
}
# MAIN
if {$argc == 0 || $argc > 2} {
puts "Usage: $argv0 inputSyntaxFile \[outputSyntaxFile\]"
}
if {![file exists [lindex $argv 0]]} {
error "Input file does not exist"
}
if {[file size [lindex $argv 0]] > $MAXFILESIZE} {
error "Input file size exceeds limit"
}
if {$argc == 2} {
set outh [open [lindex $argv 1] w]
} else {
set outh stdout
}
set ifInterp [interp create -safe] ;# safe interpreter for condition eval
set syntax [loadSyntax [lindex $argv 0]]
set nwSyntax {SET PRINTBACK=ON.
}
while {1} {
set expansion 0
set lexerID [::lexer::init syntax 0]
while {[set sym [::lexer::getSym $lexerID]] != {}} {
if {[regexp -nocase {^DEFINE} $sym] && [string equal [string trimleft
[::lexer::commandBuffer $lexerID]] $sym]} {
set macroDef [string trim [defineMacro $lexerID]]
} elseif {[regexp -nocase {^(INC|INS)} $sym] && [string equal [string
trimleft [::lexer::commandBuffer $lexerID]] $sym]} {
insertFile $lexerID
} elseif {[info exists defined([string toupper $sym]:numArgs)]} {
set sym [string toupper $sym]
if {$defined($sym:numArgs)} {
set copyNdx [::lexer::index $lexerID]
append nwSyntax "\n* /* Expanded: [::lexer::getCmd $lexerID]
*/.\n"
::lexer::newIndex $lexerID $copyNdx
} else {
append nwSyntax " /* expanded $sym */ "
}
append nwSyntax [string trim [expandMacro $sym $lexerID]]
set expansion 1
if {$defined($sym:numArgs)} {
append nwSyntax "\n"
}
} else {
append nwSyntax $sym
}
}
::lexer::destroy $lexerID
regsub -all {\n\n} $nwSyntax "\n" nwSyntax
regsub -all {\n\n} $nwSyntax "\n" nwSyntax
if {!$expansion} break
set syntax $nwSyntax
set nwSyntax {}
}
puts -nonewline $outh $nwSyntax
close $outh
/* !AGGSUB aggregates in the WORKFILE the means of VARI breaking down by
SPACCA. */
/* It creates a subtotal (first var) * var for each of the breakdowns. */
/* *** ATTENTION *** DON'T use (VARA TO VARC) but always (VARA VARB VARC) */
DEFINE !AGGSUB ( SPACCA= !ENCLOSE('(',')') /VARI=!ENCLOSE('(',')')
/FUNZ= !TOKENS(1) !DEFAULT("MEAN")).
DATASET COPY aggsub_work.
DATASET ACTIVATE aggsub_work.
!LET !nvar = 0
!DO !var !IN (!VARI)
!LET !nvar = !length(!concat(!blanks(!nvar), !blanks(1)))
!DOEND
!LET !nspac = 0
!DO !var !IN (!TAIL(!SPACCA))
!LET !nspac = !length(!concat(!blanks(!nspac), !blanks(1)))
AGGREGATE OUTFILE=* /BREAK = !HEAD(!SPACCA) !var
/!VARI= !FUNZ(!VARI)
!DO !vr !IN (!VARI)
!CONCAT("/N_",!vr) = N(!vr)
!DOEND
!DO !vr !IN (!VARI)
!CONCAT("/Nu_",!vr) = NU(!vr)
!DOEND
.
DATASET NAME !CONCAT("agg_",!nspac).
DATASET ACTIVATE aggsub_work.
!DOEND
DATASET ACTIVATE agg_1.
!LET !nspac = 1
!DO !var !IN (!TAIL(!TAIL(!SPACCA))).
!LET !nspac = !length(!concat(!blanks(!nspac), !blanks(1)))
ADD FILES FILE=* /FILE=!CONCAT("agg_",!nspac).
DATASET CLOSE !CONCAT("agg_",!nspac).
!DOEND.
MATCH FILES FILE=* /KEEP=!SPACCA !VARI ALL.
SELECT IF NOT MISSING(!HEAD(!TAIL(!SPACCA)))
!DO !var !IN (!TAIL(!TAIL(!SPACCA)))
OR NOT MISSING(!var)
!DOEND
.
SORT CASES BY !SPACCA.
APPLY DICTIONARY FROM=aggsub_work.
DATASET CLOSE aggsub_work.
DATASET CLOSE *.
!ENDDEFINE.
DATA LIST LIST /respondent (F5.0) area (F1.0) sex (A1) brand (F1.0)
price (F12.0) overall (F2.0).
BEGIN DATA
1 1 F 4 1805 9
2 1 M 4 1817 10
3 3 M 1 1945 0
4 2 F 4 1412 8
5 3 M 1 1615 -1
6 1 M 1 1704 7
7 2 F 2 1321 9
8 2 M 2 1230 8
9 3 M 2 1535 6
10 3 M 1 1708 4
11 3 F 1 1495 8
12 1 M 4 1764 8
13 1 M 2 1807 8
14 2 M 1 1478 7
15 2 F 3 1370 10
16 2 M 3 1625 8
17 1 M 4 1900 -1
18 2 F 4 1637 8
19 3 M 4 1306 7
20 1 M 1 1362 8
21 3 F 3 1620 6
22 3 M 4 1578 7
23 2 F 2 1349 5
24 3 F 1 1676 9
25 2 F 2 1772 7
26 2 M 3 1486 7
27 1 F 4 1547 8
28 1 F 1 1562 10
29 2 M 2 1814 8
30 3 M 3 1777 8
END DATA.
VAR LAB area "Area" /sex "Sex" /brand "Brand" /price "Price"
/overall "Overall satisfaction score".
VAL LAB area 1 "North" 2 "Central" 3 "South" /sex "F" "Female" "M" "Male"
/brand 1 "Peerless" 2 "Super" 3 "Eccelent" 4 "Unmatched".
MISS VAL price (-1).
COMPUTE total = 1.
COMPUTE everybody = 1.
!AGGSUB SPACCA=(total everybody sex brand) VARI=(price overall).
SAVE OUTFILE = "out.sav".
----- End forwarded message -----
--
Avoid eavesdropping. Send strong encrypted email.
PGP Public key ID: 1024D/2DE827B3
fingerprint = 8797 A26D 0854 2EAB 0285 A290 8A67 719C 2DE8 27B3
See http://sks-keyservers.net or any PGP keyserver for public key.
_______________________________________________
pspp-dev mailing list
pspp-dev@gnu.org
https://lists.gnu.org/mailman/listinfo/pspp-dev
