home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / LISTING.ZIP / LISTING.BIX
Encoding:
Text File  |  1980-01-06  |  7.3 KB  |  317 lines
  1.  
  2.  
  3.  { NAME:  newprocess
  4.    EXAMPLE CALL:
  5.      p:=NewProcess(Ofs(proc),1000);
  6.      proc is the parameterless procedure, from which
  7.      the new process is created.   The stack of the
  8.      new process p is 1000 bytes.
  9.  }
  10.  function NewProcess(prog: integer; size: integer): Process;
  11.  var stack: ^integer;
  12.  begin
  13.  GetMem(stack,size);
  14.  MemW[Seg(stack^):Ofs(stack^)+size-10]:=prog;
  15.  MemW[Seg(stack^):Ofs(stack^)+size-12]:=Ofs(stack^)+size-12;
  16.  NewProcess:=Ptr(Seg(stack^),Ofs(stack^)+size-12);
  17.  end;
  18.  
  19.  
  20.  
  21.  
  22. [ Listing 1. ]
  23.  
  24. ; procedure transfer(var p1,p2: Process);
  25. ;
  26. cseg         segment 'cgroup'
  27.              assume  cs:cseg
  28. transfer     proc    near
  29. ;
  30.   push    bp       ;   Turbo Pascal generated prolog
  31.   mov     bp,sp    ;     -       -        -        -
  32. ;
  33.   pop     bp             ; Align with `newprocess' setup
  34.   les     bp,dword ptr [bp]+4  ; get address of p2
  35.   mov     ax,es:[bp]+2        ; get segment part of p2
  36.   mov     bx,es:[bp]        ; get offset part of p2
  37.   mov     bp,sp                ; bp - point to parm's
  38.   les     bp,dword ptr [bp]+8  ; get address of p1
  39.   mov     es:[bp],sp        ; store sp in offset part
  40.   mov     es:[bp]+2,ss        ; store ss in segment part
  41.   mov     ss,ax            ; new stack segment from p2
  42.   mov     sp,bx            ; new stack pointer from p2
  43.   mov     bp,sp            ; re-establish bp for epilog
  44.  ;
  45.    mov     sp,bp           ; Turbo Pascal generated epilog
  46.    pop     bp            ;     -    -    -    -
  47.    ret     8             ;     -    -    -    -
  48.  ;
  49.  transfer     endp
  50.  cseg         ends
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57. [ Listing 2a ]
  58.  
  59.  
  60.  procedure transfer(var p1,p2: process);
  61.  begin
  62.  inline(
  63.  $5D/ $C4/ $6E/ $04/ $26/ $8B/ $46/ $02/ $26/ $8B/ $5E/ $00/
  64.  $8B/ $EC/ $C4/ $6E/ $08/ $26/ $89/ $66/ $00/ $26/ $8C/ $56/
  65.  $02/ $8E/ $D0/ $8B/ $E3/ $8B/ $EC);
  66.  end;
  67.  
  68.  
  69.  
  70.  
  71. [ Listing 2b ]
  72.  
  73. cseg         segment 'cgroup'
  74.       assume  cs:cseg
  75. inthandler   proc    near
  76.   jmp    start ; jump over data area
  77. getbase:
  78.   call    base ; subroutine to get base of data area.
  79. base:
  80.   pop     di   ; pop address of base into di.
  81.   ret          ; return with offset of base in di.
  82. ;  data area:
  83. newdsword    dw   ?  ; data segment register for pascal
  84. stkoffset    dw   ?  ; offset of stack
  85. stksegment   dw   ?  ; segment of stack for pascal
  86. procoffset   dw   ?  ; offset of interrupt handler procedure
  87.                         ; segment of handler must be callsegment
  88. calloffset   dw   ?  ; offset of routine that makes short call
  89. callsegment  dw   ?  ; segment of routine that makes short call
  90. savessword   dw   ?  ; word to save ss into
  91. savespword   dw   ?  ; word to save sp into
  92. newds        equ  newdsword-base    ; offset from base to newdsword
  93. newsp        equ  stkoffset-base    ; offset from base to stkoffset
  94. newss        equ  stksegment-base   ; offset from base to stksegment
  95. handler      equ  procoffset-base   ; offset from base to procoffset
  96. caller       equ  calloffset-base   ; offset from base to calloffset
  97. savess       equ  savessword-base   ; offset from base to savessword
  98. savesp       equ  savespword-base   ; offset from base to savespword
  99. start:       
  100.   push    di                        ; save di
  101.   call    getbase                   ; get base of data area in di
  102.   mov     word ptr cs:[di]+savess,ss   ; save ss
  103.   mov     word ptr cs:[di]+savesp,sp   ; save sp
  104.   mov     ss,word ptr cs:[di]+newss    ; get new ss
  105.   mov     sp,word ptr cs:[di]+newsp    ; get new sp
  106.   push    ax          ; save the rest of the registers
  107.   push    bx
  108.   push    cx
  109.   push    dx
  110.   push    bp
  111.   push    si
  112.   push    es
  113.   push    ds
  114.   mov     ds,word ptr cs:[di]+newds   ; get ds for pascal
  115.   mov     bx,word ptr cs:[di]+handler ; get offset of handler
  116.   call    dword ptr cs:[di]+caller    ; long call to short caller
  117.   pop     ds                  ; restore all registers
  118.   pop     es                  ; and return from interrupt
  119.   pop     si
  120.   pop     bp
  121.   pop     dx
  122.   pop     cx
  123.   pop     bx
  124.   pop     ax
  125.   call    getbase
  126.   mov     ss,word ptr cs:[di]+savess
  127.   mov     sp,word ptr cs:[di]+savesp
  128.   pop     di
  129.   iret
  130. inthandler   endp
  131. cseg         ends
  132.  
  133. [ Listing 3 ]
  134.  
  135.  cseg         segment 'cgroup'
  136.           assume  cs:cseg
  137.  shortcaller  proc    far
  138.           call    bx
  139.           ret
  140.  shortcaller  endp
  141.  cseg          ends
  142.  
  143. [ Listing 4 ]
  144.  
  145. {  NAME:  newioprocess
  146.    EXAMPLE CALL:
  147.     p:=NewIoProcess(Ofs(proc),1000);
  148.    proc is the parameterless procedure, from which
  149.    the new ioprocess is created. The stack of the
  150.    new ioprocess p is 1000 bytes.
  151. }
  152. function newioprocess(proc: integer; size: integer): ioprocess;
  153. procedure shortcaller;
  154. begin
  155. inline($FF/$D3/$CB);
  156. end;
  157. const inthandler: array[1..85] of byte=
  158. (
  159. $EB, $16, $90, $E8, $00, $00, $5F, $C3, $00, $00, $00, $00,
  160. $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
  161. $57, $E8, $E7, $FF, $2E, $8C, $55, $0E, $2E, $89, $65, $10,
  162. $2E, $8E, $55, $06, $2E, $8B, $65, $04, $50, $53, $51, $52,
  163. $55, $56, $06, $1E, $2E, $8E, $5D, $02, $2E, $8B, $5D, $08,
  164. $2E, $FF, $5D, $0A, $1F, $07, $5E, $5D, $5A, $59, $5B, $58,
  165. $E8, $B8, $FF, $2E, $8E, $55, $0E, $2E, $8B, $65, $10, $5F,
  166. $CF);
  167. var area: ^integer;
  168. begin
  169. GetMem(area,size+85);
  170. Move(inthandler,area^,85);
  171. memw[Seg(area^):Ofs(area^)+ 8]:=Dseg;
  172. memw[Seg(area^):Ofs(area^)+10]:=Ofs(area^)+size+85;
  173. memw[Seg(area^):Ofs(area^)+12]:=Seg(area^);
  174. memw[Seg(area^):Ofs(area^)+14]:=proc;
  175. memw[Seg(area^):Ofs(area^)+16]:=Ofs(shortcaller)+12;
  176. memw[Seg(area^):Ofs(area^)+18]:=Cseg;
  177. newioprocess:=area;
  178. end;
  179.  
  180. [ Listing 5 ]
  181.  
  182.  {  NAME:  IoAttach
  183.     PARAMETERS:
  184.      `intnum' is an interrupt number
  185.      `proc' is an ioprocess created by newioprocess
  186.  }
  187.  procedure IoAttach(intnum: byte; proc: ioprocess);
  188.  var regs: record
  189.           ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  190.        end;
  191.  begin
  192.  with regs do
  193.     begin
  194.     ax:=$2500 + intnum;  { DOS function 25H sets an }
  195.     ds:=Seg(proc^);     { interrupt vector.        }
  196.     dx:=Ofs(proc^);
  197.     end;
  198.  MsDos(regs);       { request DOS function }
  199.  end;
  200.  
  201. [ Listing 6 ]
  202.  
  203.  {$K-} { turn off checking for stack overflow }
  204.  
  205.  program multitest;
  206.  
  207.  type Process=^integer;
  208.  
  209.      ...  { definitions of NewProcess & transfer }
  210.  
  211.  var p1,p2: process;
  212.  
  213.  procedure prog1;
  214.  begin
  215.  while true do
  216.    begin
  217.    writeln('Hi');
  218.    transfer(p1,p2);
  219.    writeln('He');
  220.    transfer(p1,p2);
  221.    end;
  222.  end;
  223.  
  224.  procedure prog2;
  225.  begin
  226.  while true do
  227.    begin
  228.    writeln('Ho');
  229.    transfer(p2,p1);
  230.    end;
  231.  end;
  232.  
  233.  var p0: process;
  234.  
  235.  procedure main;
  236.  begin
  237.  p1:=newprocess(ofs(prog1),1000);
  238.  p2:=newprocess(ofs(prog2),1000);
  239.  transfer(p0,p1);
  240.  end;
  241.  
  242.  begin main end.
  243.  
  244.  
  245.  
  246.  
  247.  
  248. [ Listing 7a ]
  249.  
  250.  Resulting output:
  251.  
  252.    Hi
  253.    Ho
  254.    He
  255.    Ho
  256.    Hi
  257.    Ho
  258.    .
  259.    .
  260.    .
  261.  
  262.  
  263.  
  264.  
  265.  
  266. [ Listing 7b ]
  267.  
  268.  {$K-}    { turn of checking for stack overflow }
  269.  
  270.  program interrupttest;
  271.  
  272.  type IoProcess = ^integer;
  273.  
  274.  var count: integer;
  275.  var timerhandler: IoProcess;
  276.  
  277.  ... { definitions of NewIoProcess and IoAttach }
  278.  
  279.  procedure incrementer;
  280.  begin
  281.  count:=succ(count);
  282.  end;
  283.  
  284.  begin
  285.  timerhandler:=NewIoProcess(Ofs(incrementer),1000);
  286.  count:=0;
  287.  IoAttach($1C,timerhandler); { attach timerhandler to user }
  288.  while true do             { timer interrupt ( 1Ch )       }
  289.     begin
  290.     writeln(count);
  291.     Delay(100);          { delay 100 milliseconds       }
  292.     end;
  293.  end.
  294.  
  295.  
  296.  
  297.  
  298.  
  299. [ Listing 8a ]
  300.  
  301.  Resulting output:
  302.  
  303.    0
  304.    1
  305.    3
  306.    5
  307.    7
  308.    8
  309.    10
  310.    12
  311.    .
  312.    .
  313.    .
  314.  
  315. [Listing 8b]
  316.  
  317.