extra/gml/gml.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors continuations debugger euler.b-rep gml.parser
   3 gml.printer gml.runtime io io.encodings.utf8 io.files kernel
   4 namespaces sequences ;
   5 IN: gml
   6
   7 TUPLE: gml-file-error pathname error ;
   8
   9 C: <gml-file-error> gml-file-error
  10
  11 M: gml-file-error error.
  12     "Error in GML file “" write
  13     dup pathname>> write "”:" print nl
  14     error>> error. ;
  15
  16 : gml-stack. ( gml -- )
  17     operand-stack>> [
  18         "Operand stack:" print
  19         [ "• " write print-gml ] each
  20     ] unless-empty ;
  21
  22 SYMBOL: gml
  23
  24 : make-gml ( quot -- gml b-rep )
  25     [
  26         <gml> gml set
  27         <b-rep> b-rep set
  28         call
  29         gml get
  30         b-rep get dup finish-b-rep
  31     ] with-scope ; inline
  32
  33 : with-gml ( gml b-rep quot -- )
  34     [
  35         [ gml set ]
  36         [ b-rep set ]
  37         [ call ]
  38         tri*
  39     ] with-scope ; inline
  40
  41 : run-gml-string ( string -- )
  42     [ gml get ] dip parse-gml exec drop ;
  43
  44 : run-gml-file ( pathname -- )
  45     [ utf8 file-contents run-gml-string ]
  46     [ <gml-file-error> rethrow ]
  47     recover ;
  48
  49 SYMBOLS: pre-hook post-hook ;
  50
  51 [ ] pre-hook set-global
  52 [ ] post-hook set-global
  53
  54 : (gml-listener) ( -- )
  55     "GML> " write flush readln [
  56         '[
  57             pre-hook get call( -- )
  58             _ run-gml-string
  59             post-hook get call( -- )
  60         ] try
  61         [ gml get gml-stack. ] try
  62         (gml-listener)
  63     ] when* ;
  64
  65 : gml-listener ( -- )
  66     [ (gml-listener) ] make-gml 2drop ;
  67
  68 MAIN: gml-listener