extra/gml/gml.factor

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