level1/90_misc.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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;; brk-buffer chain; we have to restore all those buffers on loading
   9 ;; record format:
  10 ;;   dd prev
  11 ;;   dd valpfa
  12 ;;   dd size
  13 $variable "(brk-buf-chain)" 0
  14 (hidden)
  15
  16 : (add-brk-buffer)  ( size valpfa -- )
  17   3 cells n-allot
  18   ;; prev
  19   (brk-buf-chain) @ over !
  20   dup (brk-buf-chain) ! cell+
  21   dup nrot ! cell+
  22   !
  23  $if 0
  24   ;; debug code
  25   endcr ." (save-add-brk-buffer): valpfa=0x" (brk-buf-chain) @ cell+ @ .hex8
  26   ." ; size=" (brk-buf-chain) @ 2 +cells @ .hex8
  27   ." ; name=" (brk-buf-chain) @ cell+ @ pfa->cfa cfa->nfa id. cr
  28  $endif
  29 ; (hidden)
  30
  31
  32 : (restore-brk-buffers)  ( size valpfa -- )
  33   (brk-buf-chain)
  34   begin
  35     @ ?dup
  36   while
  37     dup
  38     cell+ dup @ swap  ;; valpfa
  39     cell+ @           ;; size
  40     brk-alloc swap !
  41    $if 0
  42     ;; debug code
  43     >r
  44     endcr ." (save-restore-brk-buffers): valpfa=0x" r@ cell+ @ .hex8
  45     ." ; size=" r@ 2 +cells @ .hex8
  46     ." ; name=" r@ cell+ @ pfa->cfa cfa->nfa id. cr
  47     r>
  48    $endif
  49   repeat
  50 ; (hidden)
  51
  52 ..: (startup-init)  (restore-brk-buffers) ;..
  53
  54
  55 ;; this allocates memory with BRK
  56 : BRK-BUFFER:  ( size -- )
  57   dup >r  ;; we should notify saver about new buffer here, hence the save
  58   brk-alloc value
  59   r> latest-cfa cfa->pfa (add-brk-buffer)
  60 ;