home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / GLOBEN.ZIP / GLOBENV.ASM < prev    next >
Assembly Source File  |  1987-10-16  |  85KB  |  1,915 lines
  1.  title Global Environment Support
  2.  subttl Prologue
  3.  page 54,120
  4. ;*=====================================================================*
  5. ;*                                                                     *
  6. ;*                            G L O B E N V                            *
  7. ;*                                                                     *
  8. ;*                        Dynamic Link Routines                        *
  9. ;*                                 for                                 *
  10. ;*                     Global Environment Support                      *
  11. ;*                                                                     *
  12. ;* The Global Environment is a store of named data items that is       *
  13. ;* accessible to any process in an OS/2 system.  Data items are stored *
  14. ;* and retrieved by name, where a name is an AsciiZ string.  The value *
  15. ;* of a data item is any sequence of bytes assigned to it (usually,    *
  16. ;* but not necessarily, another AsciiZ string).                        *
  17. ;*                                                                     *
  18. ;* The following routines are exported by this package.  See procedure *
  19. ;* headings for more detail; see also the documentation file.          *
  20. ;*                                                                     *
  21. ;* GlbEnter(in:name)                                                   *
  22. ;*      defines a new name, or discovers if a name is defined.         *
  23. ;*                                                                     *
  24. ;* GlbStore(in:name, value, length) -- assign a value of a given       *
  25. ;*      length to a predefined name, replacing any value it has now.   *
  26. ;*                                                                     *
  27. ;* GlbFetch(in:name; out: value; inout:length)                         *
  28. ;*      copies the value of a name, not to exceed a specified length,  *
  29. ;*      and reports back the length copied.                            *
  30. ;*                                                                     *
  31. ;* GlbQuery(in:name; out:length)                                       *
  32. ;*      discovers if a name exists, and the length of its value.       *
  33. ;*                                                                     *
  34. ;* GlbNext(in:name, strmax; out: string, size)                         *
  35. ;*      returns the name-string lexically next-greater than the input  *
  36. ;*      name (provided it fits in strmax bytes), and the length of     *
  37. ;*      its value if any.  in:name and out:string may be the same      *
  38. ;*      space and thus the whole set of names may be scanned in order. *
  39. ;*                                                                     *
  40. ;* GlbDelete(in:name)                                                  *
  41. ;*      deletes a name and its value if any.                           *
  42. ;*                                                                     *
  43. ;* These names (in UPPER CASE) are exported for dynamic linking. See   *
  44. ;* the documentation file for details of declaration in C or Pascal.   *
  45. ;*                                                                     *
  46. ;*  Copyright (C) 1987 David E. Cortesi                                *
  47. ;*                                                                     *
  48. ;* History:                                                            *
  49. ;* 10/1/87 -- begun                                                    *
  50. ;* 10/6/87 -- substantially complete                                   *
  51. ;* 10/12/87 -- start-counter, RdrCount/WtrCount underflow prevention   *
  52. ;* 10/13/87 -- test Xtend, Gcoll and fix bugs therein                  *
  53. ;* 10/15/87 -- add Exit List routine                                   *
  54. ;*                                                                     *
  55. ;*=====================================================================*
  56.         .286P
  57. ; above should be two lines, .286 and .PRIV, but that don't work in SDK
  58.         public  GLBENTER
  59.         public  GLBSTORE
  60.         public  GLBQUERY
  61.         public  GLBFETCH
  62.         public  GLBNEXT
  63.         public  GLBDELETE
  64.  
  65.         extrn  DosSemSet:far
  66.         extrn  DosSemClear:far
  67.         extrn  DosSemRequest:far
  68.         extrn  DosSemWait:far
  69.         extrn  DosReallocSeg:far
  70.         extrn  DosExitList:far
  71.         extrn  DosEnterCritSec:far
  72.         extrn  DosExitCritSec:far
  73.  
  74.  subttl Global Data Area
  75.  page
  76. ;*=====================================================================*
  77. ;*                                                                     *
  78. ;* The package has a single data segment which is solo, common to all  *
  79. ;* processes that link this code.  All public procedures use their     *
  80. ;* caller's stack but load up the selector for this segment into DS    *
  81. ;* on entry.  Inner routines all "assume ds:GLOBDATA."                 *
  82. ;*                                                                     *
  83. ;* GLOBDATA is laid out this way, from low offsets to higher ones:     *
  84. ;*                                                                     *
  85. ;*      * fixed, defined fields use to manage the segment              *
  86. ;*              * semaphores for exclusion                             *
  87. ;*              * offsets and counts for storage management            *
  88. ;*                                                                     *
  89. ;*      * a "heap" of "objects" of variable size                       *
  90. ;*              * every object has an integral number of words         *
  91. ;*              * the first word is always the object's byte length    *
  92. ;*              * the second word is its Control index (later)         *
  93. ;*              * then follows its contents, one or more words         *
  94. ;*                                                                     *
  95. ;*      * zero or more free bytes                                      *
  96. ;*                                                                     *
  97. ;*      * an array of 4*N words, where N is the highest number of      *
  98. ;*        names ever defined.  Initially N=0.                          *
  99. ;*              * array entries are addressed *backward* from the      *
  100. ;*                size of the segment: word K is at (SegLimit - 2K).   *
  101. ;*                This permits the segment to be extended at any time. *
  102. ;*                                                                     *
  103. ;* There are a number of (fairly obvious) relationships among these    *
  104. ;* values that are assumed to be true by the using code.  However,     *
  105. ;* OS/2 gives us the ability to detect when a predecessor crashed (see *
  106. ;* the ReqCtrl procedure) and we take that as the occasion to make     *
  107. ;* explicit integrity checks of the contents of the segment (see the   *
  108. ;* Integrity procedure).  The same procedure can also be called on     *
  109. ;* every entry or every Writer exit (see ReqCtrl, WtrOut).             *
  110. ;*                                                                     *
  111. ;*=====================================================================*
  112. GLOBDATA  segment para public 'DATA'
  113. ; error codes
  114. Err_no_name     equ     1
  115. Err_name_exists equ     2
  116. Err_no_room     equ     3
  117. Err_trunc_val   equ     4
  118.  
  119. ; semaphores and counters for exclusion, see RdrIn proc and following.
  120. CtrlSem         dd      0       ; Key sem for exclusive write access
  121. WtrWait         dd      0       ; Signal to writers, last reader done
  122. RdrGate         dd      0       ; Signal to readers, last writer done
  123. RdrCount        dw      0       ; When nonzero, readers at work
  124. WtrCount        dw      0       ; When nonzero, writers waiting
  125.  
  126. ; curiosity counter to see whether start is called once or often
  127. StartCount      dw      0
  128.  
  129. ; heap management items, see GColl proc and following
  130. HeapBot         dw      EndFixed ; bottom of heap
  131. HeapMid         dw      EndFixed ; top of in-use objects
  132. HeapTop         dw      EndArray ; end of free space
  133. HeapGarb        dw      0       ; bytes of garbage in heap
  134.  
  135. SegLimit        dw      EndArray ; size of segment currently
  136.  
  137. ArraySize       dw      0       ; number of groups of 4 words in array
  138. ArrayFree       dw      0       ; number of them free (from deletes)
  139.  
  140. ; This is the end of the fixed part of GLOBDATA.  Put any added fixed
  141. ; field above this point.  DO NOT re-open the definition of this seg.
  142.  
  143. EndFixed        equ     $
  144.                 db      2048 dup(?) ; initial heap and array
  145. EndArray        equ     $
  146.  
  147. GLOBDATA        ends
  148.  
  149.  subttl Entry and Setup Formalities
  150.  page
  151. ;*=====================================================================*
  152. ;*                                                                     *
  153. ;* The "start" proc receives control when the DLL is first loaded.     *
  154. ;* It doesn't need to do anything but return 1 for success, but it     *
  155. ;* also gets the exact size of the data segment.                       *
  156. ;*                                                                     *
  157. ;*=====================================================================*
  158.  
  159. GLOBENV segment para public 'CODE'
  160.                 assume  cs:GLOBENV, ds:GLOBDATA
  161.  
  162.   start proc far
  163.                 mov     ax, seg GLOBDATA
  164.                 mov     ds, ax
  165.                 lsl     ax, ax ; yields offset of last byte (odd number)
  166.                 jz      startOK ; segment exists!
  167.                 xor     ax, ax ; initialization failed
  168.                 jmp short startExit
  169. startOK:        inc     StartCount
  170.                 test    StartCount, -2
  171.                 jnz     startExit ; don't init more than once
  172.                 inc     ax ; make length/offset-of-byte-after-seg
  173.                 mov     SegLimit, ax ; set hardware seg limit
  174.                 mov     ax,1 ; above inc could have made ax=0
  175. startExit:      ret
  176.   start endp
  177.  
  178.  subttl Exit List Items
  179.  page
  180. ;*=====================================================================*
  181. ;*                                                                     *
  182. ;* We have to know when a client is terminating, in order to keep our  *
  183. ;* Rdr/WtrCounts straight.  We maintain a per-client data area and use *
  184. ;* it to note (1) whether we've set up an Exit routine for this client *
  185. ;* and (2) what the client's state is as a reader or writer.           *
  186. ;*                                                                     *
  187. ;* The following data segment is designated (in the GLOBENV.DEF file)  *
  188. ;* as "multiple," that is, per-process.  Each process that links this  *
  189. ;* package gets a unique copy of this segment.  It's small but useful. *
  190. ;*                                                                     *
  191. ;*=====================================================================*
  192.  
  193. PERCLIENT segment byte public 'DATA'
  194. ActiveReader db 0 ; incremented for every thread of proc that's a reader
  195. ActiveWriter db 0 ; 01 when a thread is an active writer
  196. HaveExitList db 0 ; nonzero when an exit list established
  197. PERCLIENT ends
  198.  
  199. ; This subroutine returns the per-client switches in registers:
  200. ;       DH = ActiveReader  DL = ActiveWriter  AL = HaveExitList
  201.  
  202.     GetPerClient proc near
  203.         push    es
  204.         mov     ax, seg PERCLIENT
  205.         mov     es, ax
  206.         mov     dh, es:byte ptr ActiveReader
  207.         mov     dl, es:byte ptr ActiveWriter
  208.         mov     al, es:byte ptr HaveExitList
  209.         pop     es
  210.         ret
  211.     GetPerClient endp
  212.  
  213. ; This subroutine sets the per-client switches from registers as above.
  214. ; The use of the subroutines saves pushing/popping es in other code.
  215.  
  216.     PutPerClient proc near
  217.         push    es
  218.         push    ax
  219.         mov     ax, seg PERCLIENT
  220.         mov     es, ax
  221.         pop     ax
  222.         mov     es:byte ptr ActiveReader, dh
  223.         mov     es:byte ptr ActiveWriter, dl
  224.         mov     es:byte ptr HaveExitList, al
  225.         pop     es
  226.         ret
  227.     PutPerClient endp
  228.  
  229.         page
  230. ;*=====================================================================*
  231. ;*                                                                     *
  232. ;*  Exit routine: this code gets control when a client process is      *
  233. ;* terminating.  If the client was an active reader or writer, we try  *
  234. ;* to clean up after.  Perfect reliability is not assured, since there *
  235. ;* are stretches of code over which termination could cause problems   *
  236. ;* but over which the relevant PerClient flags are not yet set.        *
  237. ;*                                                                     *
  238. ;*=====================================================================*
  239.  
  240.    ExitRoutine proc far
  241.                 mov     ax, seg GLOBDATA
  242.                 mov     ds, ax
  243.  
  244.                 call    GetPerClient
  245.                 or      dl, dl          ; were we a writer?
  246.                 jz      ERCheckRdr      ; (no)
  247.  
  248. ; The dying client was the (one and only) active writer task.  Call the
  249. ; Integrity routine to clear the workspace if it's damaged.  Then exit
  250. ; as a writer.
  251.  
  252.                 call    Integrity
  253.                 call    WtrOut
  254.                 jmp short ERExit
  255.  
  256. ERCheckRdr:     or      dh, dh          ; were we one or more readers?
  257.                 jz      ERExit          ; (no)
  258.  
  259. ; The expiring process was a reader.  In fact it could have been more
  260. ; than one reader, since it could have had multiple threads and we
  261. ; allow multiple readers.  But it's down to one thread now, so check
  262. ; out on behalf of all of them.
  263.  
  264. ; We want to claim CtrlSem, but we don't want to hang the system for
  265. ; very long (Exit routines are supposed to be quick).  So we will use
  266. ; a timeout of 500L (half a second) on the SemRequest.
  267.  
  268.                 push    ds
  269.                 push    offset CtrlSem
  270.                 push    0       ; push M.S. word first,
  271.                 push    500     ; ..and least-significant second
  272.                 call    DosSemRequest
  273.                 cmp     ax, 121 ; did wait end for timeout?
  274.                 je      ERExit  ; (yes, give up)
  275.                 mov     al, dh  ; number of reader threads
  276.                 cbw             ; ..in this process
  277.                 neg     ax
  278.                 add     ax, RdrCount
  279.                 mov     RdrCount, ax
  280.                 push    ds
  281.                 push    offset CtrlSem
  282.                 call    DosSemClear
  283.  
  284. ; We don't need to, or can't, clean up, or are finished.  Exit to OS/2
  285. ; using DosExitList(3), transfer to next exit routine.
  286. ERExit:         push    3
  287.                 push    0       ; push null routine address
  288.                 push    0
  289.                 call    DosExitList ; SHOULD NOT RETURN
  290.                 ret             ; (in case it does...)
  291.     ExitRoutine endp
  292.  
  293. ; This routine sets up the above code as an Exit routine for the
  294. ; process that is currently animating this code.
  295.     SetExitList proc near
  296.                 push    ax
  297.                 push    1
  298.                 push    seg GLOBENV
  299.                 push    offset GLOBENV:ExitRoutine
  300.                 call    DosExitList
  301.                 pop     ax
  302.                 ret
  303.     SetExitList endp
  304.  
  305.     subttl Procedures for Mutual Exclusion
  306.     page
  307. ;*=====================================================================*
  308. ;*                                                                     *
  309. ;*  Define a Reader as a thread executing in GlbFetch, GlbQuery, or    *
  310. ;*  GlbNext.  These procedures don't alter any data in GLOBDATA.  Any  *
  311. ;*  number of them may run concurrently.                               *
  312. ;*                                                                     *
  313. ;*  Define a Writer as a thread executing in GlbEnter, GlbStore, or    *
  314. ;*  GlbDelete.  These procedures do alter the heap and the array.      *
  315. ;*  No other thread may be in this module while a Writer is running.   *
  316. ;*                                                                     *
  317. ;*  The simple solution would be to use one semaphore to serialize the *
  318. ;*  use of GLOBDATA. But for efficiency we would prefer to allow any   *
  319. ;*  number of readers when only readers are around, serializing only   *
  320. ;*  when a writer is running.                                          *
  321. ;*                                                                     *
  322. ;*  The full solution used here, including the use of Exit Routines    *
  323. ;*  and the handling of the per-client data area, is discussed in the  *
  324. ;*  text.  The pseudo-code precedes the main routines that follow.     *
  325. ;*                                                                     *
  326. ;*=====================================================================*
  327.  
  328. ; Local subroutine to save a few bytes on the repetitive operation of
  329. ; doing DosSemRequest(CtrlSem,-1).
  330.  
  331.     ReqCtrl proc near
  332.                 push    ds
  333.                 push    offset CtrlSem  ; push semaphore far *
  334.                 mov     ax, -1
  335.                 push    ax              ; push timeout interval
  336.                 push    ax              ; ..value of -1L = "forever"
  337.                 call    DosSemRequest
  338.                 ret
  339.     ReqCtrl endp
  340.  
  341. ; Local subroutine to save a few bytes on doing DosSemWait([ax], -1).
  342.     WaitSem proc near
  343.                 push    ds
  344.                 push    ax              ; AX = offset of a semaphore
  345.                 mov     ax, -1
  346.                 push    ax
  347.                 push    ax              ; push -1L = "forever"
  348.                 call    DosSemWait
  349.                 ret
  350.     WaitSem endp
  351.  
  352.  page
  353. ;*=====================================================================*
  354. ;*                                                                     *
  355. ;*  Readers: -- the logic of any reader procedure                      *
  356. ;*                                                                     *
  357. ;*      DosSemWait(RdrGate, -1)     -- defer to any writers            *
  358. ;*      DosSemRequest(CtrlSem, -1)  -- get exclusive use               *
  359. ;*      RdrCount = RdrCount + 1     -- check in as a reader            *
  360. ;*      DosSemClear(CtrlSem)        -- release modify-right            *
  361. ;*      -- note reader status in per-client data for termination       *
  362. ;*                                                                     *
  363. ;*      -- Here RdrCount is nonzero, so no Writer will be              *
  364. ;*      -- active and the reader may do its work.                      *
  365. ;*                                                                     *
  366. ;*      -- clear reader status in per-client data                      *
  367. ;*      DosSemRequest(CtrlSem, -1)                                     *
  368. ;*      RdrCount = RdrCount - 1     -- check out as a reader           *
  369. ;*      if RdrCount == 0 then       -- if last to leave,               *
  370. ;*          DosSemClear(WtrWait)      -- wake up any writers           *
  371. ;*      DosSemClear(CtrlSem)                                           *
  372. ;*                                                                     *
  373. ;*  end Readers.                                                       *
  374. ;*                                                                     *
  375. ;*=====================================================================*
  376.  
  377.     RdrIn   proc near
  378.                 push    ax
  379.                 push    dx
  380. ;       DosSemWait(RdrGate,-1)
  381.                 mov     ax, offset RdrGate
  382.                 call    WaitSem
  383. ;       DosSemRequest(CtrlSem, -1)
  384.                 call    ReqCtrl
  385. ;       RdrCount += 1
  386.                 inc     word ptr RdrCount
  387. ;       DosSemClear(CtrlSem)
  388.                 push    ds
  389.                 push    offset CtrlSem
  390.                 call    DosSemClear
  391. ; Since multiple readers are allowed, there could be multiple
  392. ; reader threads from one one process -- very unlikely but we
  393. ; have to permit it.  Therefore the per-client data has to be
  394. ; updated in a critical section, which freezes out other threads
  395. ; of this process but not threads of other processes...
  396.                 call    DosEnterCritSec
  397.                 call    GetPerClient
  398.                 inc     dh      ; count one more reader
  399.                 or      al, al  ; do we have an Exit routine?
  400.                 jnz     RIHasExit ; (yes)
  401.                 call    SetExitList ; no, set one up
  402.                 dec     al      ; ..and indicate so
  403. RIHasExit:      call    PutPerCLient
  404.                 call    DosExitCritSec
  405.                 pop     dx
  406.                 pop     ax
  407.                 ret
  408.     RdrIn   endp
  409.  
  410.     RdrOut  proc near
  411.                 push    ax      ; save caller's exit code
  412.                 push    dx
  413. ; Update per-client info for exit routine
  414.                 call    DosEnterCritSec
  415.                 call    GetPerClient
  416.                 dec     dh
  417.                 jns     ROPCOk
  418.                 xor     dh, dh  ; should never be used
  419. ROPCOk:         call    PutPerClient
  420.                 call    DosExitCritSec
  421.  
  422. ;       DosSemRequest(CtrlSem, -1)
  423.                 call    ReqCtrl
  424. ;       RdrCount -= 1
  425.                 dec     word ptr RdrCount
  426.                 js      RdrCntBad ; certain rare disasters
  427. ;       if RdrCount == 0
  428. NotMinusRdr:    jnz     NotLastRdr
  429. ;           DosSemClear(WtrWait)
  430. LastRdrOut:     push    ds
  431.                 push    offset WtrWait
  432.                 call    DosSemClear
  433. ;       DosSemClear(CtrlSem)
  434. NotLastRdr:     push    ds
  435.                 push    offset CtrlSem
  436.                 call    DosSemClear
  437.                 pop     dx
  438.                 pop     ax
  439.                 ret
  440. ; should never occur: RdrCount was zero or minus when we dec'd it.
  441. ; set it to zero and pretend it never happened.  The alternative
  442. ; would be to leave it negative, which would freeze writers forever.
  443. ; Which is worse, uncontrolled writers or frozen ones?
  444. RdrCntBad:      mov     RdrCount, 0
  445.                 jmp short LastRdrOut
  446.     RdrOut  endp
  447. page
  448. ;*=====================================================================*
  449. ;*                                                                     *
  450. ;*  Writers: -- the logic of any writer procedure                      *
  451. ;*                                                                     *
  452. ;*      DosSemRequest(CtrlSem, -1)  -- get exclusive use               *
  453. ;*      DosSemSet(RdrGate)          -- close gate to more readers      *
  454. ;*      WtrCount = WtrCount + 1     -- check in as a writer            *
  455. ;*      While RdrCount > 0 do       -- while any working readers,      *
  456. ;*          DosSemSet(WtrWait)         -- set sem while holding CtrlSem*
  457. ;*          DosSemClear(CtrlSem)       -- enable Readers to exit       *
  458. ;*          DosSemWait(WtrWait, -1)    -- wait for last Reader         *
  459. ;*          DosSemRequest(CtrlSem, -1) -- regain exclusion             *
  460. ;*      end while                                                      *
  461. ;*      -- note writer status in per-client data for termination       *
  462. ;*                                                                     *
  463. ;*      -- Here the writer owns CtrlSem and RdrCount is zero, so has   *
  464. ;*      -- exclusive use of the resource and may do its work.          *
  465. ;*                                                                     *
  466. ;*      -- clear writer status in per-client data                      *
  467. ;*      WtrCount = WtrCount - 1     -- check out as a writer           *
  468. ;*      if WtrCount == 0 then       -- if no other writers waiting,    *
  469. ;*          DosSemClear(RdrGate)      -- waken any waiting readers     *
  470. ;*      DosSemClear(CtrlSem)        -- let readers, other writers in   *
  471. ;*                                                                     *
  472. ;*  end Writers.                                                       *
  473. ;*                                                                     *
  474. ;*=====================================================================*
  475.  
  476.     WtrIn  proc near
  477.                 push    ax
  478.                 push    dx
  479.                 call    ReqCtrl
  480.                 push    ds
  481.                 push    offset RdrGate
  482.                 call    DosSemSet
  483.                 inc     word ptr WtrCount
  484. WhileRdrs:      test    word ptr RdrCount, -1
  485.                 jz      NoRdrsNow
  486.                 push    ds
  487.                 push    offset WtrWait
  488.                 call    DosSemSet
  489.                 push    ds
  490.                 push    offset CtrlSem
  491.                 call    DosSemClear
  492.                 mov     ax, offset WtrWait
  493.                 call    WaitSem
  494.                 call    ReqCtrl
  495.                 jmp short WhileRdrs
  496. NoRdrsNow:
  497. ; Since there's only one writer thread anywhere, we have exclusive
  498. ; use of this per-client data as well.
  499.                 call    GetPerClient
  500.                 or      al, al ; do we have an exit routine for you?
  501.                 jnz     WIHasExit ; (yes)
  502.                 dec     al      ; no, be we will
  503.                 call    SetExitList
  504. WIHasExit:      mov     dl, 1
  505.                 call    PutPerClient
  506.                 pop     dx
  507.                 pop     ax
  508.                 ret
  509.     WtrIn  endp
  510.  
  511.     WtrOut proc near
  512.                 push    ax
  513.                 push    dx
  514.                 call    GetPerClient
  515.                 mov     dl, 0
  516.                 call    PutPerClient
  517.                 dec     word ptr WtrCount
  518.                 js      BadWtrCount
  519.                 jnz     MoreWriters
  520. LastWtrOut:     push    ds
  521.                 push    offset RdrGate
  522.                 call    DosSemClear
  523. MoreWriters:    push    ds
  524.                 push    offset CtrlSem
  525.                 call    DosSemClear
  526.                 pop     dx
  527.                 pop     ax
  528.                 ret
  529. ; Should not occur: WtrCount was zero/minus when we dec'd it.
  530. ; Set it to zero and pretend it never happened.  The alternative
  531. ; is to leave it negative and freeze readers out forever.
  532. BadWtrCount:    mov     WtrCount, 0
  533.                 jmp short LastWtrOut
  534.     WtrOut endp
  535.  
  536.  subttl Heap Space Management
  537.   page
  538. ;*=====================================================================*
  539. ;*                                                                     *
  540. ;* This is heap-object management.  At this level we are concerned     *
  541. ;* with managing a variable number of objects of variable size; we     *
  542. ;* don't care what they contain (both names and values are objects).   *
  543. ;*                                                                     *
  544. ;* Objects always are multiples of a word in size, word-aligned. All   *
  545. ;* objects begin with two words: a length word and a Control word.     *
  546. ;* The length contains the total length of the object, which is always *
  547. ;* even and at least 6.                                                *
  548. ;*                                                                     *
  549. ;* The Control word is the offset in the Array of the object's Anchor. *
  550. ;* That is, the word at SegLimit-Control contains the offset of this   *
  551. ;* object's contents (4 bytes into it).  Except inside these routines, *
  552. ;* EVERY reference to an object starts with its Anchor.  That gives us *
  553. ;* the freedom to move objects around during garbage collections, so   *
  554. ;* long as we update their anchors appropriately.                      *
  555. ;*                                                                     *
  556. ;* If an object's control word is zero, it is a free object, which is  *
  557. ;* to say it is garbage waiting to be collected.                       *
  558. ;*                                                                     *
  559. ;* The procedures in this group are:                                   *
  560. ;*      GColl : collect garbage and compress the heap.                 *
  561. ;*      XTend : extend the segment size and move the Array up.         *
  562. ;*      GetSpace(S) : allocate an object of size S, using a variety    *
  563. ;*                      of strategies for calling GColl or XTend       *
  564. ;*      MakeObj(C,S) : create an object of size S anchored at C        *
  565. ;*      FreeObj(C) : free the object whose anchor is C                 *
  566. ;*                                                                     *
  567. ;*=====================================================================*
  568.         page
  569. ;*=====================================================================*
  570. ;*                                                                     *
  571. ;* This is the garbage-collect subroutine.  It is called from either   *
  572. ;* GetSpace or GetDesc, and this is its logic:                         *
  573. ;*                                                                     *
  574. ;*       P = HeapBot                                                   *
  575. ;*       while (P->C) do P += P->L                                     *
  576. ;*       /* P points to first garbage */                               *
  577. ;*       Q = P                                                         *
  578. ;*       while (Q < HeapMid) && (Q->C == 0) do Q += Q->L               *
  579. ;*       /* Q points to first data after garbage or to top of heap */  *
  580. ;*       while (Q < HeapMid)                                           *
  581. ;*               if (Q->C)                                             *
  582. ;*                       Anchors[C] = P+4                              *
  583. ;*                       Copy object *Q to *P for length Q->L          *
  584. ;*                       P += Q->L                                     *
  585. ;*               Q += Q->L                                             *
  586. ;*       HeapMid = P                                                   *
  587. ;*=====================================================================*
  588.  
  589.     GColl proc near
  590.                 push    bx
  591.                 push    cx
  592.                 push    si
  593.                 push    di
  594.                 push    es
  595.  
  596.                 push    ds      ; get es==ds
  597.                 pop     es
  598.                 cld             ; and forward moves
  599.  
  600. ;*       P = HeapBot                                                   *
  601.                 mov     di, word ptr HeapBot
  602.  
  603. ;*       while (P->C) do P += P->L                                     *
  604. LookForGarb:    test    word ptr [di + 2], -1
  605.                 jz      AtFirstGarb
  606.                 add     di, word ptr [di]
  607.                 jmp short LookForGarb
  608. AtFirstGarb:
  609.  
  610. ;*       /* P points to first garbage */                               *
  611. ;*       Q = P                                                         *
  612.                 mov     si, di
  613.  
  614. ;*       while (Q < HeapMid) && (Q->C == 0) do Q += Q->L               *
  615. LookForObj:     cmp     si, word ptr HeapMid
  616.                 jnb     AtNextObj
  617.                 test    word ptr [si + 2], -1
  618.                 jnz     AtNextObj
  619.                 add     si, word ptr [si]
  620.                 jmp short LookForObj
  621. AtNextObj:
  622.  
  623. ;*       /* Q points to first data after garbage or to top of heap */  *
  624. ;*       while (Q < HeapMid)                                           *
  625. Collect:        cmp     si, word ptr HeapMid
  626.                 jnb     BeyondGarb
  627.  
  628. ;*               if (Q->C)                                             *
  629.                 test    word ptr [si + 2], -1
  630.                 jz      SkipGarb
  631.  
  632. ;*                       Anchors[C] = P+4
  633.                 mov     bx, word ptr SegLimit
  634.                 sub     bx, word ptr [si + 2] ; bx->Anchor[C]
  635.                 lea     cx, word ptr [di + 4]
  636.                 mov     word ptr [bx], cx ; Anchor[C] = P+4
  637.  
  638. ;*                       Copy object *Q to *P for length Q->L          *
  639. ;*                       P += Q->L                                     *
  640.                 mov     cx, word ptr [si] ; cx=length, always even
  641.                 shr     cx, 1           ; move by words for speed
  642.              rep movsw
  643.                 jmp short Collect       ; "Q" updated by move
  644.  
  645. ;*               Q += Q->L                                             *
  646. SkipGarb:       add     si, word ptr [si]
  647.                 jmp short Collect
  648.  
  649. ;*       HeapMid = P                                                   *
  650. BeyondGarb:     mov     word ptr HeapMid, di
  651.  
  652.                 pop     es
  653.                 pop     di
  654.                 pop     si
  655.                 pop     cx
  656.                 pop     bx
  657.                 ret
  658.     GColl endp
  659.         page
  660. ;*=====================================================================*
  661. ;*                                                                     *
  662. ;* This is the segment-extend routine, XTend(ax=amount).  It is called *
  663. ;* either from GetSpace or GetDesc to make GLOBDATA space by extending *
  664. ;* it to higher addresses and moving the Array up in it.  If adding    *
  665. ;* ax=amount to the present segment size would blow the 64K limit,     *
  666. ;* we return with carry set.  Otherwise we use DosReallocSeg to        *
  667. ;* make the segment bigger.  If that fails we return with carry set.   *
  668. ;*                                                                     *
  669. ;* When the segment did stretch, we relocate the array of anchor words *
  670. ;* to its new high end, adjust HeapTop, and return carry clear.        *
  671. ;*                                                                     *
  672. ;*=====================================================================*
  673.  
  674.  
  675.     Xtend proc near
  676.                 push    bx
  677.                 push    cx
  678.                 push    si
  679.                 push    di
  680.                 push    es
  681.  
  682.                 add     ax, word ptr SegLimit
  683.                 jc      Over64K         ; (blows the limit)
  684.  
  685.                 mov     di, ax          ; di = future SegLimit
  686.                 push    ax
  687.                 push    ds
  688.                 call    DosReallocSeg   ; (size, selector)
  689.                 or      ax, ax
  690.                 stc
  691.                 jnz     ReallocFailed
  692.  
  693.                 mov     si, word ptr SegLimit
  694.                 sub     si, 2           ; si -> last word in array
  695.                 mov     word ptr SegLimit, di
  696.                 sub     di, 2           ; di -> last word in segment
  697.  
  698.                 mov     cx, ArraySize   ; cx = # of 4-word groups
  699.                 shl     cx, 2           ; cx = # of words
  700.                 push    ds              ; ds:si->last word to move
  701.                 pop     es              ; es:di->where to move it
  702.                 std                     ; move runs downwards
  703.              rep movsw
  704.                 add     di, 2           ; di -> last-moved word
  705.                 mov     word ptr HeapTop, di
  706.                 clc
  707. Over64K:
  708. ReallocFailed:
  709.                 pop     es
  710.                 pop     di
  711.                 pop     si
  712.                 pop     cx
  713.                 pop     bx
  714.                 ret
  715.     Xtend endp
  716.         page
  717. ;*=====================================================================*
  718. ;*                                                                     *
  719. ;* This is GetSpace(cx=S).  It is called only from MakeObj().          *
  720. ;* Its job is to find space for an object with S bytes of contents,    *
  721. ;* returning the offset or zero for failure.                           *
  722. ;*                                                                     *
  723. ;* The first step it is to increment S by 4 to allow for Length and    *
  724. ;* Control words, and to round it up to a word multiple.               *
  725. ;*                                                                     *
  726. ;* Then we start on our strategies.  They are chosen based on the      *
  727. ;* assumptions that GColl is a costly routine to call, so we want to   *
  728. ;* call it as rarely as possible.  But Xtend is just as costly and     *
  729. ;* could involve us in segment swapping delays, so we want to call it  *
  730. ;* even less often.                                                    *
  731. ;*                                                                     *
  732. ;* 1. If there's room between HeapMid and HeapTop, use it.  That's     *
  733. ;*    easy and quick both.                                             *
  734. ;*                                                                     *
  735. ;* 2. Ok, if HeapGarb is at least 8*S, do a garbage collection and     *
  736. ;*    then allocate space at HeapMid.  The 8* multiplier is to reduce  *
  737. ;*    the number of GColls when a couple of variables are being        *
  738. ;*    reassigned over and over.  The next 7 calls can likely use (1).  *
  739. ;*                                                                     *
  740. ;* 3. No good?  We must be low on space.  Let Z be S rounded up to a   *
  741. ;*    multiple of 2048.   If we can Xtend by that much, do it.  The    *
  742. ;*    extra bytes will keep us up in step (1) for the next few calls.  *
  743. ;*                                                                     *
  744. ;* 4. If that fails we can get nervous.  If HeapGarb is at least S,    *
  745. ;*    call GColl and use the space it frees.                           *
  746. ;*                                                                     *
  747. ;* 5. No YET?  Ok, if we can Xtend by exactly S, do that.              *
  748. ;*                                                                     *
  749. ;* If all the above fail, return an offset of zero to say failure.     *
  750. ;*                                                                     *
  751. ;*=====================================================================*
  752.  
  753.     GetSpace proc near
  754.  
  755.                 push    bx
  756.                 push    cx
  757.  
  758.                 mov     ax, cx
  759.                 add     ax, 4+1 ; extend S for Length, Control
  760.                 and     ax, -2  ; ..and round to words.
  761.                 mov     cx, ax  ; save in CX for later.
  762.  
  763. Strategy1:      add     ax, HeapMid
  764.                 cmp     ax, HeapTop
  765.                 ja      Strategy2
  766.                 jmp     ThereIsRoom
  767.  
  768. Strategy2:      mov     ax, HeapGarb
  769.                 shr     ax, 3
  770.                 cmp     ax, cx
  771.                 jb      Strategy3
  772.                 call    GColl
  773.                 jmp     ThereIsRoom
  774.  
  775. Strategy3:      mov     ax, cx
  776.                 add     ax, 2047
  777.                 and     ax, -2048
  778.                 call    Xtend
  779.                 jc      Strategy4
  780.                 jmp     ThereIsRoom
  781.  
  782. Strategy4:      cmp     cx, HeapGarb
  783.                 ja      Strategy5
  784.                 call    GColl
  785.                 jmp     ThereIsRoom
  786.  
  787. Strategy5:      mov     ax, cx
  788.                 call    Xtend
  789.                 jnc     ThereIsRoom
  790.                 mov     ax, 0
  791.                 jmp     GSexit
  792.  
  793. ; We get here when we know that HeapMid+S <= HeapTop, and therefore...
  794. ThereIsRoom:
  795.                 mov     bx, HeapMid
  796.                 mov     word ptr [bx], cx       ; set the L word
  797.                 mov     word ptr [bx+2], 0      ; set zero control
  798.                 add     cx, bx
  799.                 mov     HeapMid, cx
  800.                 lea     ax, [bx + 4]
  801.  
  802. ; We get here with the desired offset, or zero, in AX
  803. GSexit:         pop     cx
  804.                 pop     bx
  805.                 ret
  806.     GetSpace endp
  807.  page
  808. ;*=====================================================================*
  809. ;*                                                                     *
  810. ;* This is FreeObj(dx=Control), to free the object owned by anchor     *
  811. ;* word Array[Control] if there is one.                                *
  812. ;*                                                                     *
  813. ;*=====================================================================*
  814.  
  815.     FreeObj proc near
  816.                 push    ax
  817.                 push    bx
  818.                 push    di
  819.  
  820.                 mov     bx, SegLimit
  821.                 sub     bx, dx
  822.                 mov     di, word ptr [bx]
  823.                 or      di, di
  824.                 jz      NoObjectToFree
  825.                 mov     ax, word ptr [di - 4]   ; get object's size
  826.                 add     ax, HeapGarb
  827.                 mov     HeapGarb, ax            ; update garbage count
  828.                 mov     word ptr [di - 2], 0    ; mark object garbage
  829.                 mov     word ptr [bx], 0        ; unhook anchor
  830.  
  831. NoObjectToFree:
  832.                 pop     di
  833.                 pop     bx
  834.                 pop     ax
  835.                 ret
  836.     FreeObj endp
  837.  page
  838. ;*=====================================================================*
  839. ;*                                                                     *
  840. ;* This is MakeObj(cx=Size, dx=Control), to create an object of Size   *
  841. ;* under anchor word Array[Control], returning ax=0 if we succeed and  *
  842. ;* ax = 3 if we can't get room.                                        *
  843. ;*                                                                     *
  844. ;* Incidentally if that Anchor presently has an object, we free it.    *
  845. ;*                                                                     *
  846. ;*=====================================================================*
  847.     MakeObj proc near
  848.                 push    bx
  849.                 push    di
  850.  
  851.                 call    FreeObj         ; free present value
  852.                 call    GetSpace        ; get new space?
  853.                 or      ax, ax
  854.                 jnz     GotTheSpace
  855.                 mov     ax, Err_no_room
  856.                 jmp     MOExit
  857.  
  858. GotTheSpace:    mov     di, ax
  859.                 mov     word ptr [di - 2], dx ; set control wd
  860.                 mov     bx, SegLimit
  861.                 sub     bx, dx          ; bx->anchor
  862.                 mov     word ptr [bx], di
  863.                 xor     ax, ax          ; return 0 for success
  864.  
  865. MOExit:         pop     di
  866.                 pop     bx
  867.                 ret
  868.     MakeObj endp
  869.  subttl Descriptor Array Management
  870.  page
  871. ;*=====================================================================*
  872. ;*                                                                     *
  873. ;*  Pay attention, this is highly sophisticated.  Really.  Now, what   *
  874. ;* we gotta do is create the logical effect of four parallel arrays:   *
  875. ;*                                                                     *
  876. ;*   indirect      For each defined      names    values   sizes       *
  877. ;*  +--------+     name there is a     +--------+--------+--------+    *
  878. ;*  |        |     dedicated row of    |        |        |        |    *
  879. ;*  +--------+     three adjacent      +--------+--------+--------+    *
  880. ;*  |        |     words: anchors for  |        |        |        |    *
  881. ;*  +--------+     the name object and +--------+--------+--------+    *
  882. ;*  |        |     the value object if |        |        |        |    *
  883. ;*                 any, and the size                                   *
  884. ;* of the value. These descriptors are allocated first come first      *
  885. ;* served and when a name is deleted the descriptor is zeroed, and     *
  886. ;* reused for later names as needed.                                   *
  887. ;*                                                                     *
  888. ;* However we need to keep track of names in lexical order.  For this  *
  889. ;* purpose we have a separate array in which we store the indexes of   *
  890. ;* the descriptors in their sequence.  When a name is deleted, the     *
  891. ;* indirect array has to be compressed, so its vacant entries are      *
  892. ;* always at the bottom.                                               *
  893. ;*                                                                     *
  894. ;* OK, now we can't allocate a fixed size of these since we haven't    *
  895. ;* got a clue as to how many names will be defined in a typical        *
  896. ;* system, or even if there is such a thing as "typical."  So these    *
  897. ;* arrays have to expand as names are defined.  Great; the heap grows  *
  898. ;* up from low addresses, we will have the array grow down from high   *
  899. ;* ones.  Wait a minute, there's TWO arrays, and BOTH grow...          *
  900. ;*                                                                     *
  901. ;* Solution: the arrays grow at the same rate, so interleave them.     *
  902. ;* Every added name adds four words down from the end of the segment,  *
  903. ;* three of which are its descriptor and the fourth is available for   *
  904. ;* extending the Indirect array.  The whole array is always at the     *
  905. ;* very end of the segment, so it can always be addressed by offsets   *
  906. ;* backwards from SegLimit.  The heap can be grown by extending the    *
  907. ;* segment and then sliding the array out to the end (see Xtend()).    *
  908. ;*                                                                     *
  909. ;* To index the Indirect array, jump by 8 bytes.  That is, Indirect[j] *
  910. ;* is the word *(Seglimit - 8j - 8).  To index the descriptors,        *
  911. ;* also jump by 8 but start higher.  To find Descrip[k,name] go to     *
  912. ;* (Seglimit - 8k - 6), and so forth.                                  *
  913. ;*                                                                     *
  914. ;* Actually we don't go through the whole charade of keeping index     *
  915. ;* numbers j or k; we store the offset of words from the end of the    *
  916. ;* segment -- not j or k but (8j+8) or (8k+6).  Thus the control word  *
  917. ;* in the name object of name k is (8k+6), and in the value object of  *
  918. ;* name k is (8k+4).  And the indirect entry that points to name k     *
  919. ;* also contains (8k+6).                                               *
  920. ;*                                                                     *
  921. ;* I think we'll call these backward offsets, backoffs.                *
  922. ;*                                                                     *
  923. ;* Notice that we return backoffs, not offsets.  Also note that our    *
  924. ;* callers will carry these as backoffs.  The reason is that if you    *
  925. ;* call MakeObj(), the segment could get extended, which would make    *
  926. ;* an offset invalid -- but backoffs aren't affected.                  *
  927. ;*                                                                     *
  928. ;* GetDesc() : allocate a descriptor trio and return dx=backoff of the *
  929. ;* first word, the name-anchor.                                        *
  930. ;*                                                                     *
  931. ;* GetIWord() : locate the first free Indirect word and return its     *
  932. ;* backoff in dx.  There is an assumption that GetDesc will always     *
  933. ;* be called before GetIWord.                                          *
  934. ;*                                                                     *
  935. ;* GetDesc may have to extend the Arrays down into the heap to get     *
  936. ;* room.  If the heap's full, it tries first to GColl, then to Xtend   *
  937. ;* by 1K.  If it can't get room at all it returns carry set.           *
  938. ;*                                                                     *
  939. ;*=====================================================================*
  940.  
  941.     GetDesc proc near
  942.  
  943.                 push    ax
  944.                 push    bx
  945.                 test    word ptr ArrayFree, -1
  946.                 jz      ArrayIsFull
  947.  
  948. ; There's an empty descriptor somewhere in the array.  Scan for it.
  949.                 mov     bx, SegLimit
  950.                 sub     bx, 6
  951. GDScanDesc:     test    word ptr [bx], -1
  952.                 jz      GotMTDesc
  953.                 sub     bx, 8
  954.                 jmp short GDScanDesc
  955.  
  956. ; The array is full; create an empty entry by extending it backward.
  957. ArrayIsFull:    mov     bx, HeapMid
  958.                 add     bx, 8
  959.                 cmp     bx, HeapTop
  960.                 jbe     RoomToGrow
  961.  
  962. ; There isn't room to extend down.  If there's garbage, collect it.
  963.                 test    word ptr HeapGarb, 0fff0h ; at least 16 bytes?
  964.                 jz      TryStretch
  965.                 call    GColl
  966.                 jmp short RoomToGrow ; (there is now)
  967.  
  968. ; There's no garbage either, try to extend, and if that fails, quit.
  969. TryStretch:     mov     ax, 1024
  970.                 call    Xtend
  971.                 jnc     RoomToGrow
  972.                 jmp short GDExit ; with carry set
  973.  
  974. ; One way or another there is room to extend the Array space 4 words.
  975. ; Do that, zero the contents, and call it a free entry.
  976. RoomToGrow:     mov     bx, HeapTop
  977.                 sub     bx, 8
  978.                 mov     HeapTop, bx
  979.                 add     bx, 2           ; bx->name word
  980.                 mov     word ptr [bx], 0
  981.                 mov     word ptr [bx+2], 0
  982.                 mov     word ptr [bx+4], 0
  983.                 inc     ArraySize
  984.                 inc     ArrayFree
  985.  
  986. ; Here, bx->an empty descriptor.  Convert that positive offset to
  987. ; a backoff in dx.  Decrement ArrayFree since this desc is in use.
  988. GotMTDesc:      mov     dx, SegLimit
  989.                 sub     dx, bx
  990.                 dec     ArrayFree
  991.                 clc
  992.  
  993. ; Exit here with carry set or not, as appropriate
  994. GDExit:         pop     bx
  995.                 pop     ax
  996.                 ret
  997.     GetDesc endp
  998.  
  999. ;*=====================================================================*
  1000. ;*                                                                     *
  1001. ;* This is GetIWord(). On the assumption that GDesc() has been called  *
  1002. ;* first, we can be sure that one more descriptor has been created     *
  1003. ;* than has been sorted, and therefore there is an Array word free for *
  1004. ;* the Indirect array entry.                                           *
  1005. ;*   Since the Indirect list is kept compact under deletions, its      *
  1006. ;* first free entry is the word at (HeapTop + 8*(ArrayFree)).          *
  1007. ;*                                                                     *
  1008. ;*=====================================================================*
  1009.     GetIWord proc near
  1010.                 mov     dx, ArrayFree
  1011.                 shl     dx, 3
  1012.                 add     dx, HeapTop
  1013.                 sub     dx, SegLimit
  1014.                 neg     dx              ; make a backoff of it.
  1015.                 ret
  1016.     GetIWord endp
  1017.  
  1018.  subttl String Operations
  1019.  page
  1020. ;*=====================================================================*
  1021. ;*                                                                     *
  1022. ;*  These simple string operations encapsulate the CPU's string ops    *
  1023. ;* and provide for preserving the DI and SI regs for reuse.            *
  1024. ;*                                                                     *
  1025. ;* StrLen( es:di ) : cx=length inclusive of null at end                *
  1026. ;*                                                                     *
  1027. ;* StrCpy( ds:si to es:di for cx )   using word copies for speed       *
  1028. ;*                                                                     *
  1029. ;* StrCmp( ds:si vs es:di to a null) : sign and Z flag                 *
  1030. ;*                                                                     *
  1031. ;*=====================================================================*
  1032.  
  1033.     StrLen proc near
  1034.  
  1035.                 push    di
  1036.                 push    ax
  1037.                 mov     cx, -1          ; asciiz strings go forever
  1038.                 xor     ax, ax          ; up to a null, anyway
  1039.                 cld
  1040.         repne   scasb                   ; decrements cx at least once
  1041. ;                          cx = -(nonzero length + 2)
  1042.                 inc     cx
  1043.                 neg     cx
  1044.                 pop     ax
  1045.                 pop     di
  1046.                 ret
  1047.     StrLen endp
  1048.  
  1049.     StrCpy proc near
  1050.  
  1051.                 push    si
  1052.                 push    di
  1053.                 push    cx
  1054.                 cld
  1055.                 test    cx, 1
  1056.                 jz      CXIsEven
  1057.                 movsb                   ; move the odd byte
  1058. CXIsEven:       shr     cx, 1           ; get count of words
  1059.                 jcxz    CXIsZero        ; allow for 1 and zero
  1060.              rep movsw                  ; move words
  1061.  
  1062. CXIsZero:       pop     cx
  1063.                 pop     di
  1064.                 pop     si
  1065.                 ret
  1066.     StrCpy endp
  1067.  
  1068.     StrCmp proc near
  1069.  
  1070.                 push    ax
  1071.                 push    di
  1072.                 push    si
  1073.                 mov     al, byte ptr [si]
  1074.                 cmp     al, 1 ; is left string a null?
  1075.                 jb      StrMisMatch ; (if so, it's "low")
  1076.  
  1077. StrStillEqual:  lodsb           ; al = *(ds:si++)
  1078.                 scasb           ; flags = (as :: *(es:di++))
  1079.                 jnz     StrMisMatch ; stop at first mismatch
  1080.                 or      al, al  ; equal nulls?
  1081.                 jnz     StrStillEqual ; equal nonnulls, continue
  1082. StrMisMatch : ; or end of equal strings
  1083.  
  1084.                 pop     si
  1085.                 pop     di
  1086.                 pop     ax
  1087.                 ret
  1088.     StrCmp endp
  1089.  subttl Name-Search Routines
  1090. page
  1091. ;*=====================================================================*
  1092. ;*                                                                     *
  1093. ;* SearchGE(es:di) compares the string es:di to each of the defined    *
  1094. ;* names in ascending lexical order until (a) the end of the array     *
  1095. ;* is found, (b) a match is found, (c) a lexically-greater name is     *
  1096. ;* seen.  In case (b) the Z flag will be true and dx will contain the  *
  1097. ;* backoff of the matching name's descriptor words.  In case (c) the   *
  1098. ;* flags will be set for "ja" (es:di is less, defined name is "above") *
  1099. ;* and in case (a) the flags will be set for "jb" (es:di is greater    *
  1100. ;* and last-tested name was "below," or else the address of the next   *
  1101. ;* Indirect word was "below" the last one of all).                     *
  1102. ;*                                                                     *
  1103. ;*=====================================================================*
  1104.     SearchGE proc near
  1105.                 push    ax
  1106.                 push    bx
  1107.                 push    cx
  1108.                 push    si
  1109.                 mov     cx, ArrayFree
  1110.                 shl     cx, 3
  1111.                 add     cx, HeapTop     ; cx->last valid Indirect Wrd
  1112.                 mov     bx, SegLimit
  1113.  
  1114. SGELoop:        sub     bx, 8           ; bx->next Indirect word
  1115.                 cmp     bx, cx
  1116.                 jb      SGEExit
  1117.                 mov     dx, word ptr [bx] ; dx is descriptor backoff
  1118.                 mov     si, SegLimit
  1119.                 sub     si, dx          ; si->descriptor
  1120.                 mov     si, word ptr [si] ; si->name object
  1121.                 call    StrCmp
  1122.                 jb      SGELoop
  1123. ; search is over, dx = backoff of desc of name >= es:di
  1124. ; search is over, or failed
  1125. SGEExit:        pop     si
  1126.                 pop     cx
  1127.                 pop     bx
  1128.                 pop     ax
  1129.                 ret
  1130.     SearchGE endp
  1131.  
  1132. ;*=====================================================================*
  1133. ;*                                                                     *
  1134. ;* SearchGT(es:di) does the same as SearchGE() but rejects the equal   *
  1135. ;* condition.  The code differs only in the jump condition at the end  *
  1136. ;* of the search loop.                                                 *
  1137. ;*                                                                     *
  1138. ;*=====================================================================*
  1139.     SearchGT proc near
  1140.                 push    ax
  1141.                 push    bx
  1142.                 push    cx
  1143.                 push    si
  1144.                 mov     cx, ArrayFree
  1145.                 shl     cx, 3
  1146.                 add     cx, HeapTop     ; cx->last valid Indirect Wrd
  1147.                 mov     bx, SegLimit
  1148.  
  1149. SGTLoop:        sub     bx, 8           ; bx->next Indirect word
  1150.                 cmp     bx, cx
  1151.                 jb      SGTExit
  1152.                 mov     dx, word ptr [bx] ; dx is descriptor backoff
  1153.                 mov     si, SegLimit
  1154.                 sub     si, dx          ; si->descriptor
  1155.                 mov     si, word ptr [si] ; si->name object
  1156.                 call    StrCmp
  1157.                 jbe     SGTLoop
  1158. ; search is over, dx = backoff of desc of name > es:di
  1159. ; search is over, or failed
  1160. SGTExit:        pop     si
  1161.                 pop     cx
  1162.                 pop     bx
  1163.                 pop     ax
  1164.                 ret
  1165.     SearchGT endp
  1166.  
  1167.  subttl The ENTER Funtion
  1168.  page
  1169. ;*=====================================================================*
  1170. ;*                                                                     *
  1171. ;* GLBENTER(in: name).  This is a Writer procedure.                    *
  1172. ;*                                                                     *
  1173. ;*      Look up the name; if an equal condition is found return error  *
  1174. ;* name-exists.  Get a descriptor; if fails, return error no-room.     *
  1175. ;* Get an object for the name; if fails return no-room.  Copy name     *
  1176. ;* string into object.  Get Indirect word.  Insertion-sort the new     *
  1177. ;* new name into the Indirect array.                                   *
  1178. ;*                                                                     *
  1179. ;*=====================================================================*
  1180.  
  1181. EntParmLen      equ     4       ; one far ptr is only parm
  1182. EntNameAdr      equ     6       ; bp offset of first parm
  1183. EntSave1stGT    equ     -2      ; scratch word
  1184.  
  1185.     GLBENTER proc far
  1186.  
  1187.                 push    bp
  1188.                 mov     bp, sp
  1189.                 sub     sp, 2   ; make room on stack
  1190.  
  1191.                 push    bx
  1192.                 push    cx
  1193.                 push    dx
  1194.                 push    si
  1195.                 push    di
  1196.  
  1197.                 push    ds
  1198.                 push    es
  1199.                 mov     ax, seg GLOBDATA
  1200.                 mov     ds, ax
  1201.  
  1202. ; Get exclusive access to GLOBDATA
  1203.                 call    WtrIn
  1204.  
  1205. ; look up name; if a match is found return error_name_exists
  1206.                 les     di, dword ptr [bp + EntNameAdr]
  1207.                 call    SearchGE
  1208.                 jne     EntSaveInsPt
  1209.                 mov     ax, Err_name_exists
  1210.                 jmp     EntExit
  1211.  
  1212. ; save insertion point: if there is a lexically greater name, dx
  1213. ; contains the backoff of its descriptor.  Save 0 if there is no
  1214. ; greater name.
  1215. EntSaveInsPt:   ja      EntSaveIns2
  1216.                 mov     dx, 0   ; indicate "none greater"
  1217. EntSaveIns2:    mov     [bp + EntSave1stGT], dx
  1218.  
  1219. ; get a descriptor and handle a failure
  1220. EntGetDesc:     call    GetDesc
  1221.                 jnc     EntGetObj
  1222.                 mov     ax, Err_no_room
  1223.                 jmp     EntExit
  1224.  
  1225. ; get an object to hold the name (dx now has backoff of descriptor)
  1226. EntGetObj:      call    StrLen          ; cx = length of *es:di
  1227.                 call    MakeObj         ; (cx, dx)
  1228.                 or      ax, ax          ; got it?
  1229.                 jz      EntCopy         ; (yes)
  1230.                 jmp     EntExit         ; (no, ax=error code)
  1231.  
  1232. ; copy name string into object.
  1233. EntCopy:        mov     bx, SegLimit
  1234.                 sub     bx, dx
  1235.                 mov     di, word ptr [bx]
  1236.                 push    ds
  1237.                 pop     es              ; es:di -> object
  1238.                 lds     si, dword ptr [bp + EntNameAdr]
  1239.                 call    StrCpy
  1240.                 push    es              ; es:di -> object with name
  1241.                 pop     ds              ; restore ds base
  1242.  
  1243. ; Get the Indirect word at the end of the array and put our
  1244. ; descriptor's backoff into it.  Then swap it into position in the
  1245. ; array.  The right position is the one now occupied by the first name
  1246. ; that is lexically greater, and we saved its descriptor backoff earlier.
  1247.                 mov     cx, dx          ; save our descriptor backoff
  1248.                 call    GetIWord        ; dx = IWord at end, that of
  1249.                 mov     bx, SegLimit    ; ..a name greater than all
  1250.                 sub     bx, dx          ; bx->end Iword
  1251. ; We saved a zero earlier if there was no greater name.  If there is
  1252. ; no greater name, the right place for our descriptor is the end spot.
  1253.                 test    word ptr [bp + EntSave1stGT], -1 ;
  1254.                 jz      EntStoreIt      ; no, put it here
  1255. ; Slide all greater names down in the the Indirect list and put our
  1256. ; new name in the spot now occupied by the next-greater one.  The
  1257. ; backoff of that name is saved on the stack.
  1258. EntSwapIword:   mov     ax, word ptr [bx+8] ; get next Iword
  1259.                 mov     word ptr [bx], ax ; and pull it down
  1260.                 add     bx, 8           ; step to next
  1261.                 cmp     ax, word ptr [bp + EntSave1stGT] ; this one?
  1262.                 jne     EntSwapIword    ; no, keep swapping
  1263. EntStoreIt:     mov     word ptr [bx], cx ; store desc in place
  1264.                 mov     ax, 0           ; set zero retcode
  1265.  
  1266. ; Exit after setting ax = result code
  1267. EntExit:        call    WtrOut
  1268.                 pop     es
  1269.                 pop     ds
  1270.                 pop     di
  1271.                 pop     si
  1272.                 pop     dx
  1273.                 pop     cx
  1274.                 pop     bx
  1275.                 pop     bp      ; our scratch word
  1276.                 pop     bp      ; the saved bp
  1277.                 ret     EntParmLen
  1278.     GLBENTER endp
  1279.  subttl The STORE Funtion
  1280.  page
  1281. ;*=====================================================================*
  1282. ;*                                                                     *
  1283. ;* GLBSTORE(in: name, value, length).  This is a writer procedure      *
  1284. ;*                                                                     *
  1285. ;*      Look up the name; if an equal condition is not found return    *
  1286. ;* error no-name.  Using the length given, make a new object           *
  1287. ;* anchored in the value word for this name.  Copy the value to the    *
  1288. ;* new object.  Set the length word.                                   *
  1289. ;*                                                                     *
  1290. ;*=====================================================================*
  1291.  
  1292. StoParmLen equ 10       ; ten bytes of parm
  1293. StoNameAdr equ 12       ; bp offset of name
  1294. StoValAdr  equ  8       ; bp offset of value
  1295. StoLenAdr  equ  6       ; bp offset of value
  1296.  
  1297.     GLBSTORE proc far
  1298.  
  1299.                 push    bp
  1300.                 mov     bp, sp
  1301.  
  1302.                 push    bx
  1303.                 push    cx
  1304.                 push    dx
  1305.                 push    si
  1306.                 push    di
  1307.  
  1308.                 push    ds
  1309.                 push    es
  1310.                 mov     ax, seg GLOBDATA
  1311.                 mov     ds, ax
  1312.  
  1313. ; Get exclusive access to GLOBDATA
  1314.                 call    WtrIn
  1315.  
  1316. ; look up name; if no match is found return err_no_name
  1317.                 les     di, dword ptr [bp + StoNameAdr]
  1318.                 call    SearchGE
  1319.                 je      StoMakeIt
  1320.                 mov     ax, err_no_name
  1321.                 jmp     StoExit
  1322.  
  1323. ; Make a new object for the value of the found name
  1324. StoMakeIt:      sub     dx, 2   ; make the backoff of the value
  1325.                 call    FreeObj ; get rid of present value
  1326.                 mov     cx, word ptr [bp + StoLenAdr]
  1327.                 jcxz    StoCopyIt
  1328.                 call    MakeObj
  1329.                 or      ax, ax  ; got it?
  1330.                 jz      StoCopyIt
  1331.                 jmp     StoExit ; (no, and ax=error code)
  1332.  
  1333. ; Copy the value to the new object, if there is a value.
  1334. StoCopyIt:      push    ds
  1335.                 pop     es
  1336.                 mov     bx, SegLimit
  1337.                 sub     bx, dx
  1338.                 mov     word ptr [bx + 2], cx ; set length word
  1339.                 jcxz    StoNoCopy ; don't load meaningless address
  1340.                 mov     di, [bx]
  1341.                 lds     si, [bp + StoValAdr]
  1342.                 call    StrCpy
  1343.                 push    es      ; recover our DS
  1344.                 pop     ds
  1345. StoNoCopy:      xor     ax, ax
  1346.  
  1347. ; Exit with ax set to appropriate error code
  1348. StoExit:        call    WtrOut
  1349.                 pop     es
  1350.                 pop     ds
  1351.                 pop     di
  1352.                 pop     si
  1353.                 pop     dx
  1354.                 pop     cx
  1355.                 pop     bx
  1356.                 pop     bp
  1357.                 ret     StoParmLen
  1358.     GLBSTORE endp
  1359.  subttl The DELETE Funtion
  1360.  page
  1361. ;*=====================================================================*
  1362. ;*                                                                     *
  1363. ;* GLBDELETE(in: name).  This is a writer procedure.                   *
  1364. ;*                                                                     *
  1365. ;*      Look up the name; if an equal condition is not found return    *
  1366. ;* error no-name.  Use FreeObj to free the name and value objects      *
  1367. ;* (which sets zero in the name and value words) and set zero in the   *
  1368. ;* length word.  Increment the count of free names.  Run down the      *
  1369. ;* Indirect list and find the word that points to the deleted name,    *
  1370. ;* then continue down the list compacting it up.                       *
  1371. ;*                                                                     *
  1372. ;*=====================================================================*
  1373.  
  1374. DelNameAdr equ  6       ; bp offset of value
  1375. DelParmLen equ  4       ; four bytes of parameters
  1376.  
  1377.     GLBDELETE proc far
  1378.  
  1379.                 push    bp
  1380.                 mov     bp, sp
  1381.  
  1382.                 push    bx
  1383.                 push    cx
  1384.                 push    dx
  1385.                 push    si
  1386.                 push    di
  1387.  
  1388.                 push    ds
  1389.                 push    es
  1390.                 mov     ax, seg GLOBDATA
  1391.                 mov     ds, ax
  1392.  
  1393. ; Get exclusive access to GLOBDATA
  1394.                 call    WtrIn
  1395.  
  1396. ; look up name; if no match is found return err_no_name
  1397.                 les     di, dword ptr [bp + DelNameAdr]
  1398.                 call    SearchGE
  1399.                 je      DelKillIt
  1400.                 mov     ax, err_no_name
  1401.                 jmp     DelExit
  1402.  
  1403. ; save a copy of the name's backoff for use in compacting
  1404. DelKillIt:      mov     cx, dx
  1405.  
  1406. ; Free the name and value objects, zero the length
  1407.                 call    FreeObj         ; free name object
  1408.                 sub     dx, 2           ; make backoff of value
  1409.                 call    FreeObj         ; free value if any
  1410.                 add     dx, 2
  1411.                 mov     bx, SegLimit
  1412.                 sub     bx, dx
  1413.                 mov     word ptr [bx + 4], 0
  1414.  
  1415. ; Scan down the Indirect array looking for the one that pointed
  1416. ; to this name.  There has to be one.
  1417.  
  1418.                 mov     bx, SegLimit
  1419. DelScan1:       sub     bx, 8
  1420.                 cmp     cx, [bx]
  1421.                 jnz     DelScan1
  1422.  
  1423. ; Scan the rest of the way back bringing name entries up over this
  1424. ; one.  Don't scan past the current end.
  1425.                 mov     cx, ArrayFree   ; free before this one
  1426.                 shl     cx, 3
  1427.                 add     cx, HeapTop ; cx -> present last entry
  1428.  
  1429. DelScan2:       cmp     bx, cx
  1430.                 jz      DelScanOver
  1431.                 mov     ax, word ptr [bx - 8]
  1432.                 mov     word ptr [bx], ax
  1433.                 sub     bx, 8
  1434.                 jmp short DelScan2
  1435.  
  1436. DelScanOver:    xor     ax, ax
  1437.                 inc     ArrayFree
  1438.  
  1439. ; Exit with ax set to appropriate error code
  1440. DelExit:        call    WtrOut
  1441.                 pop     es
  1442.                 pop     ds
  1443.                 pop     di
  1444.                 pop     si
  1445.                 pop     dx
  1446.                 pop     cx
  1447.                 pop     bx
  1448.                 pop     bp
  1449.                 ret     DelParmLen
  1450.     GLBDELETE endp
  1451.  
  1452.  subttl The QUERY Function
  1453.  page
  1454. ;*=====================================================================*
  1455. ;*                                                                     *
  1456. ;* GLBQUERY(in: name; out: sizeword) : this is a Reader procedure      *
  1457. ;*                                                                     *
  1458. ;*      Look up the name; if an equal condition is not found return    *
  1459. ;* error no-name.  Pick up the name's size-word and store it in the    *
  1460. ;* second parameter, and return zero.                                  *
  1461. ;*                                                                     *
  1462. ;*=====================================================================*
  1463.  
  1464. QryNameAdr equ  10      ; bp offset of name pointer
  1465. QrySizeAdr equ  6       ; bp offset of size-word pointer
  1466. QryParmLen equ  8       ; bytes of parameters
  1467.  
  1468.     GLBQUERY proc far
  1469.  
  1470.                 push    bp
  1471.                 mov     bp, sp
  1472.  
  1473.                 push    bx
  1474.                 push    cx
  1475.                 push    dx
  1476.                 push    si
  1477.                 push    di
  1478.  
  1479.                 push    ds
  1480.                 push    es
  1481.                 mov     ax, seg GLOBDATA
  1482.                 mov     ds, ax
  1483.  
  1484. ; Get shared access to GLOBDATA
  1485.                 call    RdrIn
  1486.  
  1487. ; look up name; if no match is found return err_no_name
  1488.                 les     di, dword ptr [bp + QryNameAdr]
  1489.                 call    SearchGE
  1490.                 je      QueryIt
  1491.                 mov     ax, err_no_name
  1492.                 jmp     QryExit
  1493.  
  1494. ; dx is the backoff of the name's descriptor, get bx->descriptor
  1495. QueryIt:        mov     bx, SegLimit
  1496.                 sub     bx, dx
  1497.                 mov     ax, word ptr [bx + 4] ; ax = size
  1498.  
  1499. ; store the length in the given word
  1500.                 les     di, dword ptr [bp + QrySizeAdr]
  1501.                 mov     word ptr es:[di], ax
  1502.                 xor     ax, ax
  1503.  
  1504. ; Exit with ax set to appropriate error code
  1505. QryExit:        call    RdrOut
  1506.                 pop     es
  1507.                 pop     ds
  1508.                 pop     di
  1509.                 pop     si
  1510.                 pop     dx
  1511.                 pop     cx
  1512.                 pop     bx
  1513.                 pop     bp
  1514.                 ret     QryParmLen
  1515.     GLBQUERY endp
  1516.  
  1517.  subttl The FETCH Function
  1518.  page
  1519. ;*=====================================================================*
  1520. ;*                                                                     *
  1521. ;* GLBFETCH(in: name; out: valbuff, sizeword) : a Reader procedure     *
  1522. ;*                                                                     *
  1523. ;*      Look up the name; if an equal condition is not found return    *
  1524. ;* error no-name.  Select the lesser of the name's value size and the  *
  1525. ;* passed size word.  Set that in the size word.  Use it as a copy     *
  1526. ;* length in copying the value (if any) to the value buffer.  Return   *
  1527. ;* either zero or Err-trunc-val.                                       *
  1528. ;*                                                                     *
  1529. ;*=====================================================================*
  1530.  
  1531. FetNameAdr equ  14      ; bp offset of name pointer
  1532. FetBuffAdr equ  10      ; bp offset of value buffer pointer
  1533. FetSizeAdr equ  6       ; bp offset of size-word pointer
  1534. FetParmLen equ  12      ; bytes of parameters
  1535.  
  1536.     GLBFETCH proc far
  1537.  
  1538.                 push    bp
  1539.                 mov     bp, sp
  1540.  
  1541.                 push    bx
  1542.                 push    cx
  1543.                 push    dx
  1544.                 push    si
  1545.                 push    di
  1546.  
  1547.                 push    ds
  1548.                 push    es
  1549.                 mov     ax, seg GLOBDATA
  1550.                 mov     ds, ax
  1551.  
  1552. ; Get shared access to GLOBDATA
  1553.                 call    RdrIn
  1554.  
  1555. ; look up name; if no match is found return err_no_name
  1556.                 les     di, dword ptr [bp + FetNameAdr]
  1557.                 call    SearchGE
  1558.                 je      FetGetDesc
  1559.                 mov     ax, err_no_name
  1560.                 jmp     FetExit
  1561.  
  1562. ; dx is the backoff of the name's descriptor, get bx->descriptor
  1563. FetGetDesc:     mov     bx, SegLimit
  1564.                 sub     bx, dx
  1565.  
  1566. ; address the passed size-word and check the sizes.
  1567.                 les     di, dword ptr [bp + FetSizeAdr]
  1568.                 mov     cx, word ptr [bx + 4] ; ax = actual size
  1569.                 cmp     cx, word ptr es:[di] ; ..versus size limit
  1570.                 jbe     FetUseValSize
  1571.                 mov     cx, word ptr es:[di] ; truncate to limit
  1572. FetUseValSize:  mov     word ptr es:[di], cx ; set size returned
  1573.  
  1574. ; copy the value to the supplied buffer -- provided the size is
  1575. ; nonzero (don't load valbuff address when either the value is
  1576. ; null or the passed size was zero).
  1577.  
  1578.                 jcxz    FetNoCopy
  1579.                 mov     si, word ptr [bx + 2] ; ds:si -> value object
  1580.                 les     di, dword ptr [bp + FetBuffAdr]
  1581.                 call    StrCpy
  1582.  
  1583. ; set the return code depending on whether we truncated
  1584. FetNoCopy:      xor     ax, ax  ; assume zero return
  1585.                 cmp     cx, word ptr [bx + 4]
  1586.                 je      FetExit
  1587.                 mov     ax, Err_trunc_val
  1588.  
  1589. ; Exit with ax set to appropriate error code
  1590. FetExit:        call    RdrOut
  1591.                 pop     es
  1592.                 pop     ds
  1593.                 pop     di
  1594.                 pop     si
  1595.                 pop     dx
  1596.                 pop     cx
  1597.                 pop     bx
  1598.                 pop     bp
  1599.                 ret     FetParmLen
  1600.     GLBFETCH endp
  1601.  
  1602.  subttl the NEXT function
  1603.  page
  1604. ;*=====================================================================*
  1605. ;*                                                                     *
  1606. ;*  GLBNEXT(in: name, strmax; out: string, size) : a Reader proc       *
  1607. ;*                                                                     *
  1608. ;*  Locate the next name using SearchGT.  If there is none, return     *
  1609. ;*  Err_no_name.  Otherwise get the name's length with StrLen. If it's *
  1610. ;*  greater than strmax, return Err_no_room.  Otherwise set the size   *
  1611. ;*  of the value in the size word and copy the name string to string.  *
  1612. ;*                                                                     *
  1613. ;*=====================================================================*
  1614.  
  1615. NxtNameAdr equ 16       ; bp offset of name far ptr
  1616. NxtStrMax  equ 14       ; bp offset of strmax word
  1617. NxtBuffAdr equ 10       ; bp offset of string far ptr
  1618. NxtSizeAdr equ 6        ; bp offset of size far ptr
  1619. NxtParmLen equ 14       ; bytes of parameters
  1620.  
  1621.     GLBNEXT proc far
  1622.  
  1623.                 push    bp
  1624.                 mov     bp, sp
  1625.  
  1626.                 push    bx
  1627.                 push    cx
  1628.                 push    dx
  1629.                 push    si
  1630.                 push    di
  1631.  
  1632.                 push    ds
  1633.                 push    es
  1634.                 mov     ax, seg GLOBDATA
  1635.                 mov     ds, ax
  1636.  
  1637. ; Get shared access to GLOBDATA
  1638.                 call    RdrIn
  1639.  
  1640. ; Look for a next name to the input name and quit if there is none.
  1641.                 les     di, dword ptr [bp + NxtNameAdr]
  1642.                 call    SearchGT
  1643.                 ja      NxtGotOne
  1644.                 mov     ax, Err_no_name
  1645.                 jmp     NxtExit
  1646.  
  1647. ; Get the length of the found name.
  1648. NxtGotOne:      mov     bx, SegLimit
  1649.                 sub     bx, dx          ; bx -> descriptor
  1650.                 push    ds
  1651.                 pop     es
  1652.                 mov     di, word ptr [bx] ; es:di -> name string
  1653.                 call    StrLen          ; cx = length
  1654.                 mov     si, di          ; save ds:si -> name string
  1655.  
  1656. ; Check that the name will fit in the supplied buffer.
  1657.                 cmp     cx, word ptr [bp + NxtStrMax]
  1658.                 jbe     NxtNameFits
  1659.                 mov     ax, Err_no_room
  1660.                 jmp     NxtExit
  1661.  
  1662. ; Set the name's value size in the last parameter
  1663. NxtNameFits:    les     di, dword ptr [bp + NxtSizeAdr]
  1664.                 mov     ax, word ptr [bx + 4]
  1665.                 mov     word ptr es:[di], ax
  1666.  
  1667. ; Copy the name string to the output buffer
  1668.                 les     di, dword ptr [bp + NxtBuffAdr]
  1669.                 call    StrCpy
  1670.                 xor     ax, ax
  1671.  
  1672. ; Exit with ax set to appropriate error code
  1673. NxtExit:        call    RdrOut
  1674.                 pop     es
  1675.                 pop     ds
  1676.                 pop     di
  1677.                 pop     si
  1678.                 pop     dx
  1679.                 pop     cx
  1680.                 pop     bx
  1681.                 pop     bp
  1682.                 ret     NxtParmLen
  1683.     GLBNEXT endp
  1684.  
  1685.  subttl Workspace Integrity Check
  1686.  page
  1687. ;*=====================================================================*
  1688. ;*                                                                     *
  1689. ;* This routine is called to perform an integrity check of the common  *
  1690. ;* segment.  It may be have been called for diagnostic purposes, but   *
  1691. ;* in production it is called from ExitRoutine when a client process   *
  1692. ;* is terminating while still an active writer.  This could mean that  *
  1693. ;* we've had the bad luck to be struck by Control-break or a KillProc, *
  1694. ;* but it might mean a bug in this code or garbage in GlobData.        *
  1695. ;*   Oh, dear!  Is GlobDat still usable?  What we do here is attempt   *
  1696. ;* to validate the many logical propositions built into the structure  *
  1697. ;* of the heap and arrays.  If they all check out, other processes can *
  1698. ;* continue.  If any one of them fails, we have to make the segment    *
  1699. ;* usable again, and we do that by the brutal method of clearing it to *
  1700. ;* its initial state.                                                  *
  1701. ;*                                                                     *
  1702. ;*=====================================================================*
  1703.     Integrity proc near
  1704.                 push    ax
  1705.                 push    bx
  1706.                 push    cx
  1707.                 push    dx
  1708.                 push    di
  1709.  
  1710. ; check #1: HeapBot even, and <= HeapMid
  1711. Ick1:           mov     ax, HeapBot
  1712.                 test    ax, 1
  1713.                 jz      Ick1a
  1714.                 jmp     Ickfail
  1715. Ick1a:          cmp     ax, HeapMid
  1716.                 jbe     Ick2
  1717.                 jmp     IckFail
  1718.  
  1719. ; check 2: HeapMid even, and <= HeapTop
  1720. Ick2:           mov     ax, HeapMid
  1721.                 test    ax, 1
  1722.                 jz      Ick2a
  1723.                 jmp     IckFail
  1724. Ick2a:          cmp     ax, HeapTop
  1725.                 jbe     Ick3
  1726.                 jmp     IckFail
  1727.  
  1728. ; check 3: HeapTop even, and <= SegLimit (which may be 0=65K)
  1729. Ick3:           mov     ax, HeapTop
  1730.                 test    ax, 1
  1731.                 jz      Ick3a
  1732.                 jmp     IckFail
  1733. Ick3a:          cmp     ax, SegLimit
  1734.                 jbe     Ick3b
  1735.                 test    SegLimit, -1
  1736.                 jz      Ick3b
  1737.                 jmp     IckFail
  1738.  
  1739. ; check 3b: HeapGarb even and <= HeapMid-EndFixed
  1740. Ick3b:          mov     ax, HeapGarb
  1741.                 test    ax, 1
  1742.                 jz      Ick3c
  1743.                 jmp     IckFail
  1744. Ick3c:          add     ax, (offset GLOBDATA:EndFixed)
  1745.                 cmp     ax, HeapMid
  1746.                 jbe     Ick4
  1747.                 jmp     IckFail
  1748.  
  1749. ; check 4: ArrayFree <= ArraySize
  1750. Ick4:           mov     ax, ArraySize
  1751.                 cmp     ax, ArrayFree
  1752.                 jae     Ick5
  1753.                 jmp     IckFail
  1754.  
  1755. ; check 5: SegLimit - (ArraySize * 8) == HeapTop
  1756. Ick5:           shl     ax, 3
  1757.                 neg     ax
  1758.                 add     ax, SegLimit
  1759.                 cmp     ax, HeapTop
  1760.                 jz      Ick6
  1761.                 jmp     IckFail
  1762.  
  1763. ; Simpler sanity checks are ok, let's try something hard:
  1764. ;       for( P = HeapBot, G=0; P += P->L; P < HeapMid )
  1765. ;               check P->L is even, L>=6, and P+L <= HeapMid
  1766. ;               if (P->C) then
  1767. ;                       check P->C even and < SegLimit
  1768. ;                       Q = SegLimit - P->C
  1769. ;                       check Q > HeapTop
  1770. ;                       check Q->word == P+4
  1771. ;               else G += P->L
  1772. ;       check G == HeapGarb
  1773. ;
  1774. Ick6:           mov     cx, 0
  1775.                 mov     di, HeapBot
  1776. IckObjLoop:     cmp     di, HeapMid
  1777.                 jae     IckObjOver
  1778.                 mov     ax, word ptr [di]
  1779.                 test    ax, 1
  1780.                 jnz     IckObjErr
  1781.                 cmp     ax, 6
  1782.                 jb      IckObjErr
  1783.                 add     ax, di
  1784.                 cmp     ax, HeapMid
  1785.                 ja      IckObjErr
  1786.                 mov     bx, word ptr [di + 2]
  1787.                 cmp     bx, 0
  1788.                 jnz     IckObjActive
  1789.                 add     cx, word ptr [di]
  1790.                 jmp short IckObjStep
  1791. IckObjActive:   test    bx, 1
  1792.                 jnz     IckObjErr
  1793.                 cmp     bx, SegLimit
  1794.                 jb      IckObj2
  1795.                 test    Seglimit, -1
  1796.                 jnz     IckObjErr
  1797. IckObj2:        neg     bx
  1798.                 add     bx, SegLimit
  1799.                 cmp     bx, HeapTop
  1800.                 jbe     IckObjErr
  1801.                 lea     ax, word ptr [di + 4]
  1802.                 cmp     ax, word ptr [bx]
  1803.                 jnz     IckObjErr
  1804. IckObjStep:     add     di, word ptr [di]
  1805.                 jmp     IckObjLoop
  1806. IckObjErr: jmp IckFail
  1807.  
  1808. IckObjOver:     cmp     cx, HeapGarb
  1809.                 jnz     IckObjErr
  1810.  
  1811. ; All objects in the heap are believable.  Now let's test all the
  1812. ; descriptors in the Array, viz:
  1813. ;       for ( F = 0, b = SegLimit-6; b -= 8; b > HeapTop)
  1814. ;               if (b->N == 0)
  1815. ;                       check b->V == b->S == 0
  1816. ;                       ++F
  1817. ;               else
  1818. ;                       check *(b->N-2) == SegLimit - b
  1819. ;                       if (b->V == 0) check b->S == 0
  1820. ;                       else check *(b->V-2) == SegLimit - b + 2
  1821. ;                            and *(b->V-4) >= b->S
  1822. ;       check F == ArrayFree
  1823.                 mov     cx, 0
  1824.                 mov     dx, 6   ; backoff of first descriptor
  1825. IckNameLoop:    mov     bx, SegLimit
  1826.                 sub     bx, dx
  1827.                 cmp     bx, HeapTop
  1828.                 jb      IckNameOver
  1829.                 mov     di, word ptr [bx]
  1830.                 cmp     di, 0
  1831.                 jnz     IckNameActive
  1832.                 cmp     di, word ptr [bx + 2]
  1833.                 jnz     IckObjErr
  1834.                 cmp     di, word ptr [bx + 4]
  1835.                 jnz     IckObjErr
  1836.                 inc     cx
  1837.                 jmp     IckNameStep
  1838. IckNameActive:  test    di, 1
  1839.                 jnz     IckObjErr
  1840.                 cmp     dx, word ptr [di-2]
  1841.                 jnz     IckObjErr
  1842.                 mov     di, word ptr [bx + 2]
  1843.                 cmp     di, 0
  1844.                 jnz     IckValue
  1845.                 cmp     di, word ptr [bx + 4]
  1846.                 jnz     IckObjErr
  1847.                 jmp     IckNameStep
  1848. IckValue:       mov     ax, dx
  1849.                 sub     ax, 2
  1850.                 cmp     ax, word ptr [di - 2]
  1851.                 jnz     IckObjErr
  1852.                 mov     ax, word ptr [bx + 4]
  1853.                 cmp     ax, word ptr [di - 4]
  1854.                 ja      IckObjErr
  1855. IckNameStep:    add     dx, 8
  1856.                 jmp     IckNameLoop
  1857. IckNameOver:
  1858.                 cmp     cx, ArrayFree
  1859.                 je      IckSort
  1860.                 jmp     IckFail
  1861.  
  1862. ; OK, all the objects have anchors and all the anchors have objects
  1863. ; and all the descriptors are consistent.  Lastly let us see that
  1864. ; the top (ArraySize - ArrayFree) entries of the Indirect array
  1865. ; are nonzero and proper indexes to descriptors.
  1866. IckSort:        mov     cx, ArraySize
  1867.                 sub     cx, ArrayFree
  1868.                 jcxz    IckExit
  1869.                 mov     bx, SegLimit
  1870. IckSortLoop:    sub     bx, 8
  1871.                 mov     di, word ptr [bx]
  1872.                 test    di, 1
  1873.                 jz      IckSort1
  1874.                 jmp     IckFail
  1875. IckSort1:       cmp     di, 0
  1876.                 jnz     IckSort2
  1877.                 jmp     IckFail
  1878. IckSort2:       neg     di
  1879.                 add     di, SegLimit
  1880.                 cmp     di, HeapTop
  1881.                 ja      IckSort3
  1882.                 jmp     IckFail
  1883. IckSort3:       cmp     word ptr [di], 0
  1884.                 jnz     IckSort4
  1885.                 jmp     IckFail
  1886. IckSort4:       loop    IckSortLoop
  1887.                 jmp     IckExit
  1888.  
  1889. ; Come here to fail: some inconsistency puts the integrity of the
  1890. ; entire common segment in doubt.  We just clear it out, making it
  1891. ; safe to use at the expense of discarding all data.
  1892.  
  1893. IckFail:        mov     cx, ds
  1894.                 lsl     ax, cx
  1895.                 mov     SegLimit, ax
  1896.                 mov     HeapTop, ax
  1897.                 mov     ax, offset EndFixed
  1898.                 mov     HeapBot, ax
  1899.                 mov     HeapMid, ax
  1900.                 xor     ax, ax
  1901.                 mov     HeapGarb, ax
  1902.                 mov     ArraySize, ax
  1903.                 mov     ArrayFree, ax
  1904.  
  1905. ; back to work
  1906. IckExit:        pop     di
  1907.                 pop     dx
  1908.                 pop     cx
  1909.                 pop     bx
  1910.                 pop     ax
  1911.                 ret
  1912.     Integrity endp
  1913. GLOBENV Ends
  1914.         END start
  1915.