home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / utils / memory.utf (.txt) < prev    next >
Encoding:
Null Bytes Alternating  |  1995-05-19  |  4.2 KB  |  76 lines
  1. \ memory.utf .. external memory allocation system calls
  2. \ Copyright (c)1994 Jack J. Woehr
  3. \ P.O. Box 51, Golden, Colorado 80402-0051
  4. \ jax@well.sf.ca.us 72203.1320@compuserve.com
  5. \ SYSOP RCFB (303) 278-0364 2400/9600/14400
  6. \ All Rights Reserved
  7. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  8. \ This is free software and can be modified and redistributed under
  9. \ certain conditions described in the file COPYING.TXT. The
  10. \ Disclaimer of Warranty and License for this free software are also
  11. \ contained in the file COPYING.TXT.
  12. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  13.  
  14. \
  15. \ $Revision: 1.3 $
  16. \
  17.  
  18. MARKER memory.utf
  19.  
  20. \ ~~~~~~~~~~~~~~~~~~~~
  21. \ Conditional INCLUDED
  22. \ ~~~~~~~~~~~~~~~~~~~~
  23.  
  24. : PROVIDES ( c-addr u "ccc< >" --)
  25.     BL WORD FIND NIP 0=
  26.     IF INCLUDED ELSE 2DROP THEN ;
  27.  
  28. S" UTILS\UTILS.UTF" PROVIDES USEFUL
  29. S" UTILS\SYSCALLS.UTF" PROVIDES LIBRARY
  30.  
  31. CR .( Loading Memory Allocation words) CR
  32.  
  33. USEFUL DECIMAL
  34. SYSTEM-WORDLIST SET-CURRENT
  35.  
  36. \ System Calls
  37. S" GlobalAlloc" KERNEL32 SYSTEMCALL GLOBALALLOC
  38. S" GlobalReAlloc" KERNEL32 SYSTEMCALL GLOBALREALLOC
  39. S" GlobalFree" KERNEL32 SYSTEMCALL GLOBALFREE
  40. S" GetLastError" KERNEL32 SYSTEMCALL GETLASTERROR
  41.  
  42. \ Forth ALLOCATE defined in terms of above.
  43. \ Remeber to OPEN-ALL and RESOLVE-ALL before using.
  44. : ALLOCATE ( u -- a-addr ior)
  45.     0 GLOBALALLOC NIP ( discard second return) DUP 0=
  46.     IF GETLASTERROR NIP ( ditto) DUP LastError !
  47.     ELSE ABSTODATA FALSE
  48.     THEN
  49. ;
  50.  
  51. \ Forth FREE defined in terms of above.
  52. \ Remeber to OPEN-ALL and RESOLVE-ALL before using.
  53. : FREE ( a-addr -- ior)
  54.     DATATOABS GLOBALFREE NIP
  55.     IF GETLASTERROR NIP DUP LastError !
  56.     ELSE FALSE
  57.     THEN
  58. ;
  59.  
  60. \ Forth RESIZE defined in terms of above.
  61. \ Remeber to OPEN-ALL and RESOLVE-ALL before using.
  62. : RESIZE ( a-addr1 u -- a-addr2 ior)
  63.     SWAP 0 ROT ROT DATATOABS  \ -- 0 u abs-addr
  64.     GLOBALREALLOC NIP ( discard second return) DUP 0=
  65.     IF GETLASTERROR NIP ( ditto) DUP LastError !
  66.     ELSE ABSTODATA FALSE
  67.     THEN
  68. ;
  69.  
  70. USEFUL
  71.  
  72. \ ~~~~~~~~~~~~~~~~~
  73. \ End of memory.utf
  74. \ ~~~~~~~~~~~~~~~~~
  75.  
  76.