level0/urforth0_w_dp.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 ;; allocate some memory at HERE (DP or DP-TEMP), return starting address
  18 urword_forth "N-ALLOT",n_allot
  19 ;; ( n -- start-addr )
  20   UF dup 0less errid_negative_allot qerror
  21   UF dup 0x00ffffff ugreat errid_out_of_memory qerror  ;; 16MB is quite huge allocation chunk ;-)
  22   UF dp_temp @ qdup
  23   ur_if
  24     ;; ( n start-addr )
  25     UF dp_temp
  26   ur_else
  27     UF dp @ dp
  28   ur_endif
  29   ;; ( n start-addr dpaddr )
  30   ;; check for oom
  31   UF rpush
  32   ;; ( n start-addr | dpaddr )
  33   UF 2dup +
  34   UF dup dpend @ 32768 - ugreat errid_out_of_memory qerror
  35   UF temp_pool_here 256 - ugreatequ errid_out_of_memory qerror
  36   UF swap rpop addpoke
  37 urword_end
  38
  39 urword_forth "(ALIGN-HERE)",par_align_here
  40 urword_hidden
  41   if URFORTH_ALIGN_HEADERS
  42   UF here 3 and qdup
  43   ur_if
  44     UF 4 swap - dup n_allot swap erase
  45   ur_endif
  46   end if
  47 urword_end
  48
  49 urword_forth "ALLOT",allot
  50 ;; ( n -- )
  51   UF n_allot drop
  52 urword_end
  53
  54 urword_code "USED",used
  55 ;; ( -- count )
  56   push  TOS
  57   mov   TOS,[fvar_dp_data]
  58   sub   TOS,[fconst_par_code_base_addr_data]
  59   urnext
  60 urword_end
  61
  62 urword_code "UNUSED",unused
  63 ;; ( -- count )
  64   push  TOS
  65   mov   TOS,[fvar_dpend_data]
  66   sub   TOS,[fvar_dp_data]
  67   sub   TOS,32768   ; reserved area
  68   urnext
  69 urword_end
  70
  71 urword_code "HERE",here
  72 ;; ( -- addr )
  73   push  TOS
  74   ld    TOS,[fvar_dp_temp_data]
  75   or    TOS,TOS
  76   cmovz TOS,[fvar_dp_data]
  77   urnext
  78 urword_end
  79
  80 urword_code "REAL-HERE",real_here
  81 ;; ( -- addr )
  82   push  TOS
  83   ld    TOS,[fvar_dp_data]
  84   urnext
  85 urword_end
  86
  87 urword_code "PAD",pad
  88 ;; ( -- addr )
  89   push  TOS
  90   mov   TOS,[fvar_pad_area_data]
  91   urnext
  92 urword_end
  93
  94
  95 urword_forth "C,",ccomma
  96 ;; ( c -- )
  97   UF dbginfo_add_here
  98   UF 1 n_allot cpoke
  99 urword_end
 100
 101 urword_forth "W,",wcomma
 102 ;; ( w -- )
 103   UF dbginfo_add_here
 104   UF 2 n_allot wpoke
 105 urword_end
 106
 107 urword_forth ",",comma
 108 ;; ( n -- )
 109   UF dbginfo_add_here
 110   UF cell n_allot poke
 111 urword_end