level1/72_compiler_mid.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 : RECURSE  ( -- )
   8   compiler:?comp compiler:?non-macro latest-cfa compile,
   9 ; immediate
  10
  11 : RECURSE-TAIL  ( -- )
  12   compiler:?comp compiler:?non-macro latest-cfa compile lit-exectail reladdr,
  13 ; immediate
  14
  15
  16 : [CHAR]  ( -- ch )  \ word
  17   parse-name 1 <> err-char-expected ?error
  18   c@ [compile] literal
  19 ; immediate
  20
  21
  22 : '  ( -- cfa )  \ word
  23   -find-required
  24 ;
  25
  26 : [']  ( -- cfa )  \ word
  27   -find-required
  28   [compile] cfaliteral
  29 ; immediate
  30
  31
  32 : (COMPILE-CFA-LITERAL)  ( cfa -- )
  33   [compile] cfaliteral
  34   compile compile,
  35 ;
  36
  37 : COMPILE  ( -- )  \ word
  38   compiler:?comp -find-required
  39   (compile-cfa-literal)
  40 ; immediate
  41
  42 : [COMPILE]  ( -- )  \ word
  43   compiler:?comp -find-required compile,
  44 ; immediate
  45
  46 : [EXECUTE-TAIL]  ( -- )  \ word
  47   compiler:?comp -find-required compile lit-exectail reladdr,
  48 ; immediate
  49
  50
  51 ;; ANS idiocity, does this:
  52 ;; if the next word is immediate, compiles it in the current word
  53 ;; if the next word is not immediate, compiles "compile nextword"
  54 : POSTPONE  ( -- )
  55   compiler:?comp -find-required-ex -if
  56     ;; not immediate, do what "COMPILE" does
  57     (compile-cfa-literal)
  58   else
  59     ;; immediate, do what "[COMPILE]" does
  60     compile,
  61   endif
  62 ; immediate
  63
  64
  65 : (  ( -- )
  66   41 parse 2drop
  67 ; immediate
  68
  69 : \
  70   parse-skip-to-eol
  71 ; immediate
  72
  73 : \\
  74   parse-skip-to-eol
  75 ; immediate
  76
  77 : //
  78   parse-skip-to-eol
  79 ; immediate
  80
  81 : ;;
  82   parse-skip-to-eol
  83 ; immediate
  84
  85 ;; multiline comment
  86 ;; (* .... *)
  87 : (*  ( -- )  ;; *)
  88   skip-comment-multiline
  89 ; immediate
  90
  91 ;; nested multiline comment
  92 ;; (( .... ))
  93 : ((  ( -- ) ;; ))
  94   skip-comment-multiline-nested
  95 ; immediate
  96
  97
  98 ;; this copies string to PAD if it needs to be unscaped, or
  99 ;; if we're using default TIB
 100 : (parse-and-unescape)  ( ch -- addr count )
 101   parse dup ifnot exit endif
 102   tib-default? ifnot
 103     ;; check for backslash
 104     2dup [char] \ str-char-index
 105     ifnot exit endif
 106     drop
 107   endif
 108   dup #pad-area cell- u> err-string-too-long ?error
 109   over >r >r pad r@ move
 110   pad r@ str-unescape
 111   ;; it can never be bigger that the original, so it is save to compare here
 112   2dup r> r> 2dup 2>r s= if
 113     2drop 2r>
 114   else
 115     2rdrop
 116   endif
 117 ;
 118
 119 : "  ( -- addr count )  \ word  ;; "
 120   34 (parse-and-unescape) [compile] sliteral
 121 ; immediate
 122
 123 alias " S"
 124
 125
 126 : ."  ( -- )  \ word  ;; "
 127   34 (parse-and-unescape)
 128   state @ if
 129     ['] (.") compiler:custom-c1sliteral,
 130   else
 131     type
 132   endif
 133 ; immediate
 134
 135 : .(  ( -- )
 136   [char] ) (parse-and-unescape) type
 137 ; immediate