imgsrc/defs/gstparser/gstparser.st

   1 COMMENTS
   2  coded by Ketmar // Vampire Avalon (psyc://ketmar.no-ip.org/~Ketmar)
   3  Understanding is not required. Only obedience.
   4
   5  This program is free software. It comes without any warranty, to
   6  the extent permitted by applicable law. You can redistribute it
   7  and/or modify it under the terms of the Do What The Fuck You Want
   8  To Public License, Version 2, as published by Sam Hocevar. See
   9  http://sam.zoy.org/wtfpl/COPYING for more details.
  10 ENDCOMMENTS
  11
  12 COMMENT GST-style parser
  13 COMMENT
  14 COMMENT A new class is created using this syntax:
  15 COMMENT
  16 COMMENT   superclass-name subclass: new-class-name | class vars | [
  17 COMMENT     | instance vars |
  18 COMMENT     message-pattern-1 [ statements ]
  19 COMMENT     message-pattern-2 [ statements ]
  20 COMMENT     ...
  21 COMMENT   ]
  22 COMMENT
  23 COMMENT if class has no class variables, the entire '| class variables |' clause
  24 COMMENT can be omited.
  25 COMMENT
  26 COMMENT if message-pattern starts with ^, this is class message, not instance one.
  27 COMMENT
  28 COMMENT
  29 COMMENT A similar syntax is used to define new methods in an existing class.
  30 COMMENT
  31 COMMENT   class-expression extend [
  32 COMMENT     ...
  33 COMMENT   ]
  34 COMMENT
  35 COMMENT
  36 COMMENT inStream must support 3 methods:
  37 COMMENT   readChar: returns char or nil on EOS
  38 COMMENT   unreadChar: unreads char (only one is needed)
  39 COMMENT   lineNum: returns current line number
  40 COMMENT
  41
  42 CLASS GSTParser  Object  inStream errorBlock warningBlock lastMethodName lastMethodLine lastWordLine category
  43
  44 METHODS FOR GSTParser
  45 ^newWith: inStream [
  46   | obj |
  47   obj := self new.
  48   self in: obj var: #inStream put: inStream.
  49   ^obj
  50 ]
  51
  52 inStream [
  53   ^inStream
  54 ]
  55
  56 errorBlock [
  57   ^errorBlock
  58 ]
  59
  60 errorBlock: aBlock [
  61   errorBlock := aBlock
  62 ]
  63
  64 warningBlock [
  65   ^warningBlock
  66 ]
  67
  68 warningBlock: aBlock [
  69   warningBlock := aBlock
  70 ]
  71
  72 fileName [
  73   | fn li |
  74   (fn := inStream fileName) ifNil: [ ^nil ].
  75   (li := fn lastIndexOf: '/') ifNil: [ ^fn ].
  76   ^fn from: li + 1
  77 ]
  78
  79 error: aString at: lineNum [
  80   | fn |
  81   errorBlock ifNotNil: [ errorBlock value: aString value: lineNum ]
  82     ifNil: [
  83       "comment the following to avoid duplicate error messages"
  84       (aString := 'Compile error near line ' + lineNum + ': ' + aString) printNl.
  85       (fn := self fileName) ifNotNil: [ aString := fn + ': ' + aString ].
  86       super error: aString
  87     ].
  88 ]
  89
  90 error: aString [
  91   ^self error: aString at: inStream lineNum
  92 ]
  93
  94 warning: aString at: lineNum [
  95   | fn |
  96   warningBlock ifNotNil: [ warningBlock value: aString value: lineNum ]
  97     ifNil: [
  98       aString := ('Compile warning near line ' + lineNum + ': ' + aString).
  99       (fn := self fileName) ifNotNil: [ aString := fn + ': ' + aString ].
 100       aString printNl.
 101     ].
 102 ]
 103
 104 warning: aString [
 105   ^self warning: aString at: inStream lineNum
 106 ]
 107
 108
 109 dontWantEof: word [
 110   word ifNil: [ self error: 'unexpected end of file' ].
 111   ^word
 112 ]
 113
 114 expectedWord: want got: word [
 115   self error: ('"' + want +'" expected, but got "' + word + '"')
 116 ]
 117
 118 skipComment [
 119   | c |
 120   [ (c := inStream readChar) ifNil: [ ^nil ]. c == $" ] whileFalse: [ nil ].
 121 ]
 122
 123 skipBlanksAndComments [
 124   "skip blanks and comments, return nil or first non-blank char (char is eaten)"
 125   | c |
 126   [ [ (c := inStream readChar) ifNil: [ ^nil ]. c isBlank ] whileTrue: [ nil ].
 127     c == $" ] whileTrue: [ self skipComment. ].
 128   ^c
 129 ]
 130
 131 skipBlanks [
 132   "skip blanks, return nil or first non-blank char (char is not eaten)"
 133   | c |
 134   [ (c := inStream readChar) ifNil: [ ^nil ]. c isBlank ] whileTrue: [ nil ].
 135   ^inStream unreadChar: c
 136 ]
 137
 138 collectUntil: terminator to: buf [
 139   | pc c |
 140   c := $ .
 141   [ pc := c. buf << (self dontWantEof: (c := inStream readChar)). c == terminator ] whileFalse: [ nil ].
 142   (terminator == $' and: [ pc == $\ ]) ifTrue: [ buf << terminator. ^self collectUntil: terminator to: buf ].
 143   ^buf
 144 ]
 145
 146 collectBlanksAndCommentsTo: buf [
 147   | c |
 148   [ [ (self dontWantEof: (c := inStream readChar)) isBlank ] whileTrue: [ buf << c ].
 149     c == $" ] whileTrue: [ buf << c. self collectUntil: $" to: buf. ].
 150   inStream unreadChar: c.
 151 ]
 152
 153 lookAhead [
 154   | c |
 155   c := inStream readChar.
 156   ^(inStream unreadChar: c)
 157   "^(inStream unreadChar: (inStream readChar))"
 158 ]
 159
 160 readWord [
 161   "read one word from input"
 162   | word c |
 163   (c := self skipBlanksAndComments) ifNil: [ ^nil ].
 164   lastWordLine := inStream lineNum.
 165   c isAlphanumeric ifFalse: [ ^c asString ].
 166   (word := StringBuffer new) << c.
 167   [ (c := inStream readChar) ifNil: [ ^word asString ].
 168     c isAlphanumeric ] whileTrue: [ word << c ].
 169   inStream unreadChar: c.
 170   ^word asString
 171 ]
 172
 173 expectWord: word [
 174   | w |
 175   self dontWantEof: (w := self readWord).
 176   w ~= word ifTrue: [ self expectedWord: word got: w ].
 177   ^true
 178 ]
 179
 180 charIsSyntax: c [
 181   ^('.()[]#^$;{}' includesChar: c) or: [ c == $' ]
 182 ]
 183
 184 readMethodHeader [
 185   | c w body mname isKWord isUnary goon |
 186   self dontWantEof: (mname := self readWord).
 187   (self charIsSyntax: mname firstChar) ifTrue: [ self error: 'method name expected' at: lastWordLine ].
 188   lastMethodLine := lastWordLine.
 189   isKWord := false.
 190   isUnary := false.
 191   (body := StringBuffer new) << mname.
 192   mname firstChar isAlphanumeric
 193     ifTrue: [
 194       self lookAhead == $: ifTrue: [
 195         inStream readChar.
 196         isKWord := true.
 197         mname := mname + ':'.
 198         body << $:
 199        ] ifFalse: [ isUnary := true ].
 200     ] ifFalse: [
 201       "read other chars of the method name"
 202       [ (self charIsSyntax: (self dontWantEof: (c := inStream readChar))) ifTrue: [ self error: 'invalid binary method name' ].
 203         c isAlphanumeric ] whileFalse: [ body << c ].
 204       inStream unreadChar: c.  "this is not ours"
 205     ].
 206   lastMethodName := mname.
 207   isUnary ifFalse: [
 208     "now read args and rest keywords if any"
 209     [ self collectBlanksAndCommentsTo: body.
 210       "here we MUST have an argname"
 211       (self dontWantEof: (w := self readWord)).
 212       w firstChar isAlphanumeric ifFalse: [ self error: 'argument name expected' ].
 213       self lookAhead == $: ifTrue: [ self error: 'unexpected keyword' ].
 214       body << w.  "save argument name"
 215       isKWord ifTrue: [
 216          "here must be keyword or sqp"
 217          self collectBlanksAndCommentsTo: body.
 218          (self dontWantEof: (c := self lookAhead)) isAlphanumeric ifTrue: [
 219            "keyword or simple word"
 220            body << (self dontWantEof: (w := self readWord)).
 221            (self dontWantEof: inStream readChar) == $: ifFalse: [ self error: 'keyword expected' ].
 222            body << $:.
 223            lastMethodName := lastMethodName + w + ':'.
 224            goon := true.
 225           ] ifFalse: [
 226             "not a keyword"
 227             goon := false.
 228           ].
 229        ] ifFalse: [
 230          goon := false.
 231        ].
 232       goon ] whileTrue: [ nil ].
 233   ].
 234   "here MUST be sqp"
 235   self collectBlanksAndCommentsTo: body.
 236   (self dontWantEof: inStream readChar) == $[ ifFalse: [ self error: '"[" expected' ].
 237   "now skip until eol or so"
 238   [ self dontWantEof: (c := inStream readChar) isEOL ] whileFalse: [
 239     c isBlank ifFalse: [ inStream unreadChar: c. ^(body asString) removeTrailingBlanks ].
 240   ].
 241   ^(body asString) removeTrailingBlanks
 242 ]
 243
 244 readMethodBody [
 245   | c body sqcnt |
 246   body := StringBuffer new.
 247   sqcnt := 0.
 248   [ (self dontWantEof: (c := inStream readChar)) == $[ ifTrue: [ sqcnt := sqcnt + 1 ].
 249     (c == $] and: [ sqcnt = 0 ]) ]
 250    whileFalse: [
 251      c == $] ifTrue: [ sqcnt := sqcnt - 1 ].
 252      body << c.
 253      (c == $" or: [ c == $' ]) ifTrue: [ self collectUntil: c to: body ]
 254        ifFalse: [ c == $$ ifTrue: [ body << (self dontWantEof: inStream readChar) ]].
 255   ].
 256   "remove trailing blanks"
 257   body := (body asString) removeTrailingBlanks.
 258   ^(body + String newline)  "just in case"
 259 ]
 260
 261 findLeftMargin: s [
 262   | minspc lines pos mrg |
 263   minspc := s size.
 264   lines := s break: '\n'.
 265   lines do: [:l |
 266     l := l removeTrailingBlanks.
 267     l isEmpty ifFalse: [
 268       pos := 1. mrg := 0.
 269       [ (l at: pos) isBlank ] whileTrue: [ mrg := mrg + 1. pos := pos + 1 ].
 270       "mrg print. '|' print. l printNl."
 271       mrg < 1 ifTrue: [ ^0 ].
 272       minspc := minspc min: mrg.
 273     ]
 274   ].
 275   "'margin: ' print. minspc printNl."
 276   ^minspc
 277 ]
 278
 279 removeLeftMargin: s [
 280   | mrg lines sbuf |
 281   mrg := (self findLeftMargin: s) + 1.
 282   lines := s break: '\n'.
 283   sbuf := StringBuffer new.
 284   lines do: [:l |
 285     l := l removeTrailingBlanks.
 286     l isEmpty ifFalse: [ l := l from: mrg ].
 287     sbuf << '  ' << l << '\n'.
 288   ].
 289   ^sbuf asString.
 290 ]
 291
 292 parseCategory [
 293   "single-quote char already skiped"
 294   | name c |
 295   name := StringBuffer new.
 296   [ (self dontWantEof: (c := inStream readChar)) == $' ] whileFalse: [ name << c ].
 297   category := name asString.
 298 ]
 299
 300 compileMethod: aClass [
 301   "return true if method was succesfully parsed or false if sqp found"
 302   | c mtname isMeta hdr body p |
 303   (self dontWantEof: (c := self skipBlanksAndComments)) == $] ifTrue: [ ^false ].
 304   (isMeta := (c == $^)) ifFalse: [
 305     c == $' ifTrue: [ self parseCategory. ^self compileMethod: aClass ].
 306     (self charIsSyntax: c) ifTrue: [ self error: 'method name or "]" expected' ].
 307     inStream unreadChar: c.
 308   ].
 309   hdr := self readMethodHeader.
 310   body := self readMethodBody.
 311   body := self removeLeftMargin: body.
 312   "hdr print. '|' printNl. body print. '||' printNl."
 313   body := hdr + '\n' + body.
 314   mtname := (aClass getName asString) + '>>' + (isMeta ifTrue: ['^'] ifFalse: ['']) + lastMethodName.
 315   p := LstCompiler new.
 316   p errorBlock: [ :msg :lineNum | self error: 'in method "' + mtname + '": ' + msg at: lastMethodLine + lineNum - 1 ].
 317   p warningBlock: [ :msg :lineNum | self warning: 'in method "' + mtname + '": ' + msg at: lastMethodLine + lineNum - 1 ].
 318   c := (isMeta ifTrue: [ aClass class ] ifFalse: [ aClass ]).
 319   p category: category.
 320   (c addMethod: body withCompiler: p) ifNil: [ self error: 'in method "' + mtname + '": compilation error' at: lastMethodLine ].
 321   ^true
 322 ]
 323
 324 compileMethods: aClass [
 325   category := ''.
 326   [ self compileMethod: aClass ] whileTrue: [ nil ].
 327 ]
 328
 329 doExtend: className [
 330   "parse 'extend' directive"
 331   | aClass |
 332   self expectWord: '['.
 333   aClass := globals at: className asSymbol ifAbsent: [ self error: 'unknown class name: ' + className ].
 334   self compileMethods: aClass.
 335 ]
 336
 337 parseVarDefs [
 338   "parse variable definitions between '|' (if any)"
 339   | c vars |
 340   self skipBlanks.
 341   self dontWantEof: (c := inStream readChar).
 342   vars := (Array new: 0).
 343   c == $| ifTrue: [
 344     "wow! we have some vars!"
 345     [ self dontWantEof: (c := self readWord).
 346       c = '|' ]
 347      whileFalse: [
 348       c firstChar isAlphanumeric ifFalse: [ self error: 'invalid variable name: "' + c + '"' ].
 349       vars := vars with: c asSymbol.
 350     ].
 351   ] ifFalse: [
 352     inStream unreadChar: c.
 353   ].
 354   ^vars
 355 ]
 356
 357 doSubclass: className asProxy: isProxy [
 358   | aClass newClassName cvars ivars |
 359   aClass := globals at: className asSymbol ifAbsent: [ self error: 'unknown class name: ' + className ].
 360   newClassName := self readWord.
 361   self dontWantEof: newClassName.
 362   newClassName lastChar isAlphanumeric ifFalse: [ self error: 'invalid class name: "' + newClassName + '"' ].
 363   (globals at: newClassName asSymbol ifAbsent: [ nil ]) ifNotNil: [ ('redefinition of class "' + newClassName + '"') printNl ].
 364   "parse class variables (if any)"
 365   cvars := self parseVarDefs.
 366   self expectWord: '['.
 367   "parse instance variables (if any)"
 368   ivars := self parseVarDefs.
 369   "create new class"
 370   aClass := (aClass subclass: newClassName asSymbol variables: ivars classVariables: cvars asProxy: isProxy).
 371   self compileMethods: aClass.
 372   ^nil
 373 ]
 374
 375 doEval [
 376   | body |
 377   body := (self readMethodBody) removeTrailingBlanks.
 378   body isEmpty ifFalse: [ body doItSeq. ]
 379 ]
 380
 381 doRequires [
 382   | mname c |
 383   "FIXME: word parsing must be strict; also process comments"
 384   [ (self dontWantEof: (mname := self readWord)) = ']' ]
 385    whileFalse: [
 386      [ (self dontWantEof: (c := self lookAhead)) == $/ ] whileTrue: [
 387        inStream readChar.  "skip slash"
 388        ('\t\n\r ]' includesChar: (self dontWantEof: (c := self lookAhead))) ifTrue: [
 389          self error: 'invalid module name'
 390        ].
 391        mname := mname + '/' + self readWord.
 392      ].
 393      mname firstChar isAlphanumeric ifFalse: [ self error: 'module name expected' ].
 394      System loadModule: mname.
 395   ].
 396 ]
 397
 398 doSetPackage [
 399   | aName |
 400   (self dontWantEof: (aName := self readWord)) = ']' ifTrue: [ Package current: 'User'. ^self ].
 401   aName firstChar isAlphanumeric ifFalse: [ self error: 'package name expected' ].
 402   Package current: aName.  "returns isNew"
 403   (self dontWantEof: (aName := self readWord)) = ']' ifTrue: [ ^self ].
 404   ((aName = 'requires') and: [ inStream readChar == $: ]) ifFalse: [ self error: '"requires:" expected' ].
 405   self error: 'Package: no support for "requires:" yet!'.
 406   self expectWord: ']'.
 407 ]
 408
 409 readCurly [
 410   | body c |
 411   body := StringBuffer new.
 412   [ (self dontWantEof: (c := inStream readChar)) == $} ]
 413    whileFalse: [
 414      body << c.
 415      (c == $" or: [ c == $' ]) ifTrue: [ self collectUntil: c to: body ].
 416   ].
 417   ^(body asString) removeTrailingBlanks
 418 ]
 419
 420 doCommand1: cmd [
 421   inStream readChar.
 422   Case test: cmd;
 423     case: 'class' do: [ self doSubclass: 'Object' asProxy: false ];
 424     case: 'proxy' do: [ self doSubclass: 'Object' asProxy: true ];
 425     else: [ self error: ('invalid command: ' + cmd) ].
 426 ]
 427
 428 doCommand0: cmd [
 429   Case test: cmd;
 430     case: 'Eval' do: [ self doEval ];
 431     case: 'Requires' do: [ self doRequires ];
 432     case: 'Package' do: [ self doSetPackage ];
 433     else: [ self error: ('invalid command: ' + cmd) ].
 434 ]
 435
 436 doCommand2: cmd withClass: className [
 437   cmd firstChar isAlphanumeric ifFalse: [ self error: 'command name expected' ].
 438   Case test: cmd;
 439     case: 'extend' do: [ self doExtend: className ];
 440     case: 'subclass' do: [
 441       inStream readChar == $: ifFalse: [ self error: '":" expected after "subclass"' ].
 442       self doSubclass: className asProxy: false.
 443     ];
 444     else: [ self error: ('invalid command: ' + className) ].
 445 ]
 446
 447 parse [
 448   | className cmd c oldpkg |
 449   "deal with shebangs"
 450   (c := inStream readChar) == $# ifTrue: [
 451     "possible shebang, skip it"
 452     [ (c := inStream readChar) ifNil: [ ^true ].
 453       c isEOL ] whileFalse: [ nil ].
 454   ] ifFalse: [ inStream unreadChar: c ].
 455   "main part"
 456   oldpkg := Package current.
 457   Package current: 'User'.  "egg solution; should restore package on error"
 458   category := ''.
 459   [ className := self readWord ] whileNotNil: [
 460     className firstChar isAlphanumeric ifTrue: [
 461       (inStream unreadChar: (inStream readChar)) == $: ifTrue: [
 462         self doCommand1: className
 463       ] ifFalse: [
 464         (self dontWantEof: (cmd := self readWord)) = '[' ifTrue: [
 465           self doCommand0: className
 466         ] ifFalse: [
 467           self doCommand2: cmd withClass: className.
 468         ].
 469       ].
 470     ] ifFalse: [
 471       className = '{' ifFalse: [ self error: ('invalid command: ' + className) ].
 472       c := self readCurly.
 473       c isEmpty ifFalse: [ c doItSeq ].
 474     ].
 475   ].
 476   Package setCurrent: oldpkg.
 477   ^true
 478 ]
 479 !