meta/meta-00-compat.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Metacompiler
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; compatibility with older builds
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 [DEFINED] forth:(last-tload-path-addr) [IF]
  11 : @tc-tload-last-include-dir-c4s  ( -- addr )  forth:(last-tload-path-addr) ;
  12 : !tc-tload-last-include-dir-c4s  ( addr -- )  to forth:(last-tload-path-addr) ;
  13 [ELSE]
  14 : @tc-tload-last-include-dir-c4s  ( -- addr )  forth:tloader:last-include-dir-c4s ;
  15 : !tc-tload-last-include-dir-c4s  ( addr -- )  to forth:tloader:last-include-dir-c4s ;
  16 [ENDIF]
  17
  18
  19 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 [UNDEFINED] forth:parse-skip-to-eol [IF]
  21 : parse-skip-to-eol  ( -- )
  22   ;; check last delimiter
  23   (tib-last-read-char) @ 10 = if exit endif
  24   begin
  25     tib-getch ?dup
  26   while
  27     ;; ( ch -- )
  28     10 = if exit endif
  29   repeat
  30 ;
  31 [ENDIF]
  32
  33 [UNDEFINED] forth:skip-comment-multiline [IF]
  34 ;; multiline comment
  35 ;; (* .... *) -- opening eaten
  36 : skip-comment-multiline  ( -- )
  37   begin
  38     tib-getch ?dup
  39   while
  40     ;; ( ch -- )
  41     [char] * = tib-peekch [char] ) = and if tib-getch drop exit endif
  42   repeat
  43 ;
  44 [ENDIF]
  45
  46 [UNDEFINED] forth:skip-comment-multiline-nested [IF]
  47 ;; nested multiline comment
  48 ;; (( .... )) -- opening eaten
  49 : skip-comment-multiline-nested  ( -- )
  50   1  ;; current comment level
  51   begin
  52     tib-getch ?dup
  53   while
  54     ;; ( ch -- )
  55     8 lshift tib-peekch or
  56     dup 0x2828 =  ;; ((?
  57     if
  58       drop tib-getch drop  1+
  59     else
  60       0x2929 =   ;; ))
  61       if
  62         tib-getch drop  1-
  63         ?dup ifnot exit endif
  64       endif
  65     endif
  66   repeat
  67   drop
  68 ;
  69 [ENDIF]
  70
  71
  72 [UNDEFINED] (tib-set-to) [IF]
  73 : (tib-set-to)  ( addr count -- )
  74   #tib ! tib ! >in 0! bl (tib-last-read-char) !
  75 ;
  76 [ENDIF]
  77
  78
  79 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80 ;; os interface was moved to the separate vocabulary
  81 [UNDEFINED] os [IF]
  82 vocabulary os also os definitions
  83 alias forth:sys-gettickcount gettickcount
  84 alias forth:(fopen) open
  85 alias forth:(fclose) close
  86 alias forth:(fread) read
  87 alias forth:(fwrite) write
  88 alias forth:(lseek) lseek
  89 alias forth:(seek-set) seek-set
  90 alias forth:(seek-end) seek-end
  91 alias forth:o-rdonly o-rdonly
  92 alias forth:o-wronly o-wronly
  93 alias forth:o-creat o-creat
  94 alias forth:o-trunc o-trunc
  95 alias forth:s-irwxu s-irwxu
  96 alias forth:s-irgrp s-irgrp
  97 alias forth:s-ixgrp s-ixgrp
  98 alias forth:s-iroth s-iroth
  99 alias forth:s-ixoth s-ixoth
 100 alias forth:mmap mmap
 101 alias forth:munmap munmap
 102 alias forth:prot-r/w prot-r/w
 103 previous definitions
 104 [ENDIF]
 105
 106 [UNDEFINED] parse-name-ex [IF]
 107 : parse-name-ex  ( -- addr count )  parse-skip-comments parse-name ;
 108 [ENDIF]
 109
 110
 111 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 112 [UNDEFINED] enum{ [IF]
 113 vocabulary (enums) (hidden)
 114 also (enums) definitions
 115
 116 ;; etype: 0 -- bitenum, otherwise delta
 117
 118 : value  ( etype evalue -- etype enextvalue )  \ name
 119   dup constant
 120   over ?dup if + else ?dup if 1 lshift else 1 endif endif
 121 ;
 122
 123 : }  ( etype evalue -- )
 124   2drop previous
 125 ;
 126
 127 : set      ( etype evalue newvalue -- etype newvalue )  nip ;
 128 : set-bit  ( etype evalue newbit -- etype 1<<newbit )  nip 1 swap lshift ;
 129 : -set     ( etype evalue delta -- etype evalue-delta ) - ;
 130 : +set     ( etype evalue delta -- etype evalue+delta ) + ;
 131
 132 previous definitions
 133
 134 : enum{  ( -- etype enextvalue )  1 0 also (enums) ;
 135 : bitenum{  ( -- etype enextvalue )  0 1 also (enums) ;
 136 [ENDIF]