level0/urforth0_w_compiler_mid.asm

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;;
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;;
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, version 3 of the License ONLY.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 urword_forth "RECURSE",recurse
  19 urword_immediate
  20 ;; ( -- )
  21   UF latestcfa compile_comma
  22 urword_end
  23
  24
  25 urword_forth "[CHAR]",imm_char
  26 urword_immediate
  27 ;; ( -- ch )  \ word
  28   UF parse_name
  29   UF 1 nequ errid_char_expected qerror
  30   UF c@ literal
  31 urword_end
  32
  33
  34 urword_forth "'",tick
  35 ;; ( -- cfa )  \ word
  36   UF mfind not errid_word_expected qerror
  37 urword_end
  38
  39
  40 urword_forth "(COMPILE)",par_compile
  41 urword_hidden
  42 urword_arg_cfa
  43 ;; ( -- )
  44   ;; UF qcomp
  45   UF rpop dup cellinc rpush @ compile_comma
  46 urword_end
  47
  48 urword_forth "COMPILE",compile
  49 urword_immediate
  50 ;; ( -- )
  51   UF qcomp mfind not errid_word_expected qerror
  52   urcompile par_compile
  53   UF compile_comma
  54 urword_end
  55
  56 urword_forth "[COMPILE]",imm_compile
  57 urword_immediate
  58 ;; ( -- )
  59   UF qcomp
  60   UF mfind not errid_word_expected qerror
  61   UF compile_comma
  62 urword_end
  63
  64 ;; ANS idiocity, does this:
  65 ;; if the next word is immediate, compiles it in the current word
  66 ;; if the next word is not immediate, compiles "compile nextword"
  67 ;; shit
  68 urword_forth "POSTPONE",imm_postpone
  69 urword_immediate
  70 ;; ( -- )
  71   UF qcomp mfind not errid_word_expected qerror
  72   UF dup cfa2nfa nfa2ffa ffapeek par_wflag_immediate and
  73   ur_ifnot
  74     urcompile par_compile
  75   ur_endif
  76   UF compile_comma
  77 urword_end
  78
  79
  80 urword_forth "[",lsqparen
  81 urword_immediate
  82 ;; ( -- )
  83   UF state 0poke
  84 urword_end
  85
  86 urword_forth "]",rsqparen
  87 ;; ( -- )
  88   UF state 1poke
  89 urword_end
  90
  91
  92 urword_forth "(",comment_lparen
  93 urword_immediate
  94   UF 41 parse 2drop
  95 urword_end
  96
  97 urword_forth '\',comment_toeol
  98 urword_immediate
  99   ;; check last delimiter
 100   UF par_last_read_char @ 10 equal
 101   ur_if
 102     UF exit
 103   ur_endif
 104   ur_begin
 105     UF tib_getch qdup
 106   ur_while
 107     ;; ( ch -- )
 108     UF dup 13 equal
 109     ur_if
 110       UF drop tib_peekch 10 equal
 111       ur_if
 112         UF tib_getch drop
 113       ur_endif
 114       UF exit
 115     ur_endif
 116     UF 10 equal
 117     ur_if
 118       UF exit
 119     ur_endif
 120   ur_repeat
 121 urword_end
 122
 123 ; aliases
 124 urword_alias ";;",comment_toeol_semisemi,comment_toeol
 125 urword_immediate
 126 urword_alias "//",comment_toeol_slashslash,comment_toeol
 127 urword_immediate
 128
 129 ; multiline comment
 130 ; (* .... *)
 131 urword_forth "(*",comment_multiline
 132 urword_immediate
 133   ur_begin
 134     UF tib_getch qdup
 135   ur_while
 136     ;; ( ch -- )
 137     UF 42 equal tib_peekch 41 equal and
 138     ur_if
 139       UF tib_getch drop exit
 140     ur_endif
 141   ur_repeat
 142 urword_end
 143
 144 ; nested multiline comment
 145 ; (+ .... +)
 146 urword_forth "(+",comment_multiline_nested
 147 urword_immediate
 148   UF 1  ; current comment level
 149   ur_begin
 150     UF tib_getch qdup
 151   ur_while
 152     ;; ( ch -- )
 153     UF 8 lshift tib_peekch or
 154     UF dup 0x282b equal  ;; (+?
 155     ur_if
 156       UF drop tib_getch drop  1inc
 157     ur_else
 158       UF 0x2b29 equal   ;; +)
 159       ur_if
 160         UF tib_getch drop  1dec
 161         UF qdup
 162         ur_ifnot
 163           UF exit
 164         ur_endif
 165       ur_endif
 166     ur_endif
 167   ur_repeat
 168   UF drop
 169 urword_end
 170
 171
 172 urword_forth "(PARSE-COMPILE-C4STR)",par_parse_compile_strlit
 173 urword_hidden
 174 ;; ( ch -- ... )
 175   UF 34 parse_to_here
 176   ; unescape it (we don't need returned data)
 177   UF count str_unescape swap celldec !  ;; update length
 178   UF state @
 179   ur_if
 180     ; compile string literal (with trailing zero byte, not included in count)
 181     ;; this is either noop, or real copy (due to DP-TEMP)
 182     UF word_here here over count_only cellinc move
 183     UF here count_only cellinc allot
 184     UF 0 ccomma
 185   ur_else
 186     UF word_here pad word_here count_only cellinc cmove pad count
 187     ; put trailing 0 (not included in count)
 188     UF 2dup + 0cpoke
 189   ur_endif
 190 urword_end
 191
 192 urword_forth '"',double_quote
 193 urword_immediate
 194 ;; ( -- addr count )  \ word
 195   UF state @
 196   ur_if
 197     ; compile string literal
 198     urcompile strlit
 199   ur_endif
 200   UF par_parse_compile_strlit
 201 urword_end
 202
 203 urword_alias 'S"',sdquote,double_quote
 204 urword_immediate
 205
 206
 207 urword_forth '(.")',pardottype
 208 urword_hidden
 209 urword_arg_c4strz
 210   UF rpeek count type rpop count + 1inc rpush
 211 urword_end
 212
 213
 214 urword_forth '."',dot_double_quote
 215 urword_immediate
 216 ;; ( -- )  \ word
 217   UF state @
 218   ur_if
 219     ; compile string literal
 220     urcompile pardottype
 221   ur_endif
 222   UF par_parse_compile_strlit
 223   UF state @
 224   ur_ifnot
 225     UF type
 226   ur_endif
 227 urword_end
 228
 229 urword_forth ".(",dot_lparen
 230 urword_immediate
 231 ;; ( -- )  \ word
 232   UF 41 parse_to_here count str_unescape type
 233 urword_end
 234
 235
 236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 237 ;; UrForth level 1 already has it in the kernel, so i have to move it here
 238 urword_forth "[']",imm_tick
 239 urword_immediate
 240 ;; ( -- cfa )  \ word
 241   UF tick cfaliteral
 242 urword_end
 243
 244 urword_forth "CFALITERAL",cfaliteral
 245 urword_immediate
 246   UF state @ q0exit
 247   urcompile cfalit
 248   UF compile_comma
 249 urword_end