unmaintained/enchilada/printer/printer.factor

   1 ! Copyright (C) 2007 Robbert van Dalen.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 IN: enchilada.printer
   5 USING: prettyprint strings generic kernel math math.parser sequences isequences.interface isequences.base enchilada.engine ;
   6
   7 : s-append ( s1 s2 s3 -- s )
   8     swap append append ;
   9
  10 DEFER: e-print
  11 DEFER: l-print
  12
  13 GENERIC: (e-print) ( op -- string )
  14
  15 M: .- (e-print) drop "-" ;
  16 M: .# (e-print) drop "#" ;
  17 M: .$ (e-print) drop "$" ;
  18 M: .^ (e-print) drop "^" ;
  19 M: .` (e-print) drop "`" ;
  20 M: .~ (e-print) drop "~" ;
  21 M: .: (e-print) drop ":" ;
  22 M: .! (e-print) drop "!" ;
  23 M: .\ (e-print) drop "\\" ;
  24
  25 M: .+ (e-print) drop "+" ;
  26 M: .* (e-print) drop "*" ;
  27 M: ./ (e-print) drop "/" ;
  28 M: .< (e-print) drop "<" ;
  29 M: .> (e-print) drop ">" ;
  30 M: .| (e-print) drop "|" ;
  31 M: .& (e-print) drop "&" ;
  32 M: .@ (e-print) drop "@" ;
  33 M: .? (e-print) drop "?" ;
  34 M: .% (e-print) drop "%" ;
  35
  36 : (eprint-macro-expr) ( emacro -- string )
  37    dup emacro-expr dup i-length 0 =
  38    [ 2drop "" ]
  39    [ e-print swap emacro-eager? [ "==" ] [ "=" ] if swap append ] if ;
  40
  41 : (l-print1) ( e-list -- string )
  42     0 i-at dup left-side swap right-side dup 0 =
  43     [ drop dup i-length 0 = [ drop " " ] [ e-print ] if ] [ e-print swap e-print swap "=" s-append ] if ;
  44
  45 : (l-print0) ( e-list -- string )
  46     left-right [ l-print ] 2apply ";" s-append ;
  47
  48 : l-print ( e-list -- string )
  49     dup i-length dup 0 =
  50     [ 2drop "0" ] [ 1 = [ (l-print1) ] [ (l-print0) ] if ] if ;
  51
  52 : prefix-neg ( s -- s prefix )
  53    dup i-length 0 < [ -- "_" ] [ "" ] if ;
  54
  55 : (e-print3) ( symbol -- string )
  56     esymbol-seq to-sequence >string ;
  57
  58 : (e-print2) ( e-list -- string )
  59     dup integer? [ prefix-neg swap number>string append ] [ prefix-neg "[" append swap l-print "]" append append ] if ;
  60
  61 : (e-print1) ( e-expression -- string )
  62     0 i-at dup e-operator? [ (e-print) ] [ dup e-symbol? [ (e-print3) ] [ (e-print2) ] if ] if ;
  63
  64 : e-print ( e-expression -- string )
  65     dup i-length dup 0 =
  66     [ 2drop "" ]
  67     [ 1 = [ (e-print1) ] [ left-right [ e-print ] 2apply " " s-append ] if ] if ;
  68
  69 M: c-op (e-print) dup c-op-d-op swap c-op-v (e-print2) swap (e-print) " " s-append ;
  70 M: emacro (e-print) "{" swap dup emacro-symbols e-print swap (eprint-macro-expr) "}" append append append ;
  71