extra/fuel/fuel.factor

   1 ! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays classes classes.tuple compiler.units
   5 combinators continuations debugger definitions eval help
   6 io io.files io.streams.string kernel lexer listener listener.private
   7 make math namespaces parser prettyprint prettyprint.config
   8 quotations sequences strings source-files vectors vocabs.loader ;
   9
  10 IN: fuel
  11
  12 ! Evaluation status:
  13
  14 TUPLE: fuel-status in use ds? restarts ;
  15
  16 SYMBOL: fuel-status-stack
  17 V{ } clone fuel-status-stack set-global
  18
  19 SYMBOL: fuel-eval-result
  20 f clone fuel-eval-result set-global
  21
  22 SYMBOL: fuel-eval-output
  23 f clone fuel-eval-result set-global
  24
  25 SYMBOL: fuel-eval-res-flag
  26 t clone fuel-eval-res-flag set-global
  27
  28 : fuel-eval-restartable? ( -- ? )
  29     fuel-eval-res-flag get-global ; inline
  30
  31 : fuel-eval-restartable ( -- )
  32     t fuel-eval-res-flag set-global ; inline
  33
  34 : fuel-eval-non-restartable ( -- )
  35     f fuel-eval-res-flag set-global ; inline
  36
  37 : push-fuel-status ( -- )
  38     in get use get clone display-stacks? get restarts get-global clone
  39     fuel-status boa
  40     fuel-status-stack get push ;
  41
  42 : pop-fuel-status ( -- )
  43     fuel-status-stack get empty? [
  44         fuel-status-stack get pop {
  45             [ in>> in set ]
  46             [ use>> clone use set ]
  47             [ ds?>> display-stacks? swap [ on ] [ off ] if ]
  48             [
  49                 restarts>> fuel-eval-restartable? [ drop ] [
  50                     clone restarts set-global
  51                 ] if
  52             ]
  53         } cleave
  54     ] unless ;
  55
  56
  57 ! Lispy pretty printing
  58
  59 GENERIC: fuel-pprint ( obj -- )
  60
  61 M: object fuel-pprint pprint ; inline
  62
  63 M: f fuel-pprint drop "nil" write ; inline
  64
  65 M: integer fuel-pprint pprint ; inline
  66
  67 M: string fuel-pprint pprint ; inline
  68
  69 M: sequence fuel-pprint
  70     dup empty? [ drop f fuel-pprint ] [
  71         "(" write
  72         [ " " write ] [ fuel-pprint ] interleave
  73         ")" write
  74     ] if ;
  75
  76 M: tuple fuel-pprint tuple>array fuel-pprint ; inline
  77
  78 M: continuation fuel-pprint drop ":continuation" write ; inline
  79
  80 M: restart fuel-pprint name>> fuel-pprint ; inline
  81
  82 SYMBOL: :restarts
  83
  84 : fuel-restarts ( obj -- seq )
  85     compute-restarts :restarts prefix ; inline
  86
  87 M: condition fuel-pprint
  88     [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
  89
  90 M: source-file-error fuel-pprint
  91     [ file>> ] [ error>> ] bi 2array source-file-error prefix
  92     fuel-pprint ;
  93
  94 M: source-file fuel-pprint path>> fuel-pprint ;
  95
  96 ! Evaluation vocabulary
  97
  98 : fuel-eval-set-result ( obj -- )
  99     clone fuel-eval-result set-global ; inline
 100
 101 : fuel-retort ( -- )
 102     error get
 103     fuel-eval-result get-global
 104     fuel-eval-output get-global
 105     3array fuel-pprint ;
 106
 107 : fuel-forget-error ( -- ) f error set-global ; inline
 108 : fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
 109 : fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
 110
 111 : (fuel-begin-eval) ( -- )
 112     push-fuel-status
 113     display-stacks? off
 114     fuel-forget-error
 115     fuel-forget-result
 116     fuel-forget-output ;
 117
 118 : (fuel-end-eval) ( quot -- )
 119     with-string-writer fuel-eval-output set-global
 120     fuel-retort pop-fuel-status ; inline
 121
 122 : (fuel-eval) ( lines -- )
 123     [ [ parse-lines ] with-compilation-unit call ] curry
 124     [ print-error ] recover ; inline
 125
 126 : (fuel-eval-each) ( lines -- )
 127     [ 1vector (fuel-eval) ] each ; inline
 128
 129 : (fuel-eval-usings) ( usings -- )
 130     [ "USING: " prepend " ;" append ] map
 131     (fuel-eval-each) fuel-forget-error fuel-forget-output ;
 132
 133 : (fuel-eval-in) ( in -- )
 134     [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
 135
 136 : fuel-eval-in-context ( lines in usings -- )
 137     (fuel-begin-eval) [
 138         (fuel-eval-usings)
 139         (fuel-eval-in)
 140         (fuel-eval)
 141     ] (fuel-end-eval) ;
 142
 143 : fuel-begin-eval ( in -- )
 144     (fuel-begin-eval)
 145     (fuel-eval-in)
 146     fuel-retort ;
 147
 148 : fuel-eval ( lines -- )
 149     (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
 150
 151 : fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
 152
 153 : fuel-get-edit-location ( defspec -- )
 154     where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ]
 155     when* ;
 156
 157 : fuel-run-file ( path -- ) run-file ; inline
 158
 159 : fuel-startup ( -- ) "listener" run ; inline
 160
 161 MAIN: fuel-startup