ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/FORTHCMP.ZIP/MULTID.4TH

Text File | 1992-03-30 | 14.7 KB | 578 lines

\ ForthCMP  Multitasking Module
\ Copyright 1985 (C) By Thomas Almy.  All rights reserved.

\ Permission is granted to registered users of ForthCMP to sell or distribute
\ computer programs incorporating the compiled contents of this file.

\ This module writes direct to the display for terminal I/O


.( LOADING MULTID) CR
INCLUDE INTS
INCLUDE FARMEM1
10 HEX

\ If EGA is defined non-zero then 43 line EGA code is generated
FIND EGA #IF DROP #ELSE 0 CONSTANT EGA  0 CONSTANT VID-DELAY #THEN

EGA NOT #IF VARIABLE crtport  3D4 crtport ! #THEN

\ If VID-DELAY is defined non-zero then anti-snow code is added
FIND VID-DELAY #IF DROP #ELSE 0 CONSTANT VID-DELAY #THEN

VARIABLE vidseg     \ VIDEO SEGMENT
B800 vidseg !
50 CONSTANT c/l     \ Characters per line
EGA #IF 2B #ELSE 19 #THEN
   CONSTANT l/s     \ lines per screen


DECIMAL
0 0 IN/OUT NEED SINGLE
0 0 IN/OUT NEED MULTI
0 0 IN/OUT NEED PAUSE
0 0 IN/OUT NEED end-timer
0 0 IN/OUT NEED start-timer
0 0 IN/OUT NEED CLS


VARIABLE ?multi         \ true if multitasking turned on
VARIABLE user           \ disp into user segment--used at comp time
VARIABLE CTASK          \ pointer to task list
VARIABLE inexpect       \ executing EXPECT -- only one at a time, please!

 \ Semaphores

1 0 IN/OUT
: SEMA BEGIN DUP @ WHILE PAUSE REPEAT ON ;

1 0 IN/OUT
: PHORE  OFF PAUSE ;


0 0 IN/OUT
: BYE  unsetup-vid end-timer bye ;

 \ Memory management interface
1 1 IN/OUT
: GET malloc IF    ." OUT OF MEMORY " BYE THEN ;

 \ USER VARIABLES
H: UALLOT  DSEG user @  +  user ! ;
1 2 IN/OUT
H: UCREATE user @ CONSTANT ;
H: UVARIABLE UCREATE 2 UALLOT ;
H: URESET DSEG  0 user ! ;
URESET
 \ redefinition of primitive I/O functions
HEX
1 0 IN/OUT
: storecursor ( DISPL -- )  CTASK @ 12 + CS: ! ;

1 0 IN/OUT
: setcursor (  DISPL -- )
EGA #IF
    2/ DUP 0F 3D4 PC! 3D5 PC! >< 0E 3D4 PC! 3D5 PC!
#ELSE
    2/ DUP 0F crtport @ PC! crtport @ 1+ PC!
    >< 0E crtport @ PC! crtport @ 1+ PC!
#THEN
;

0 0 IN/OUT
: nocursor  l/s c/l * 2* 1- setcursor ( OFF SCREEN ! ) ;

2 0 IN/OUT
: GOTOXY  c/l * + 2*  storecursor ;


EGA #IF
0 0 IN/OUT
CODE set-ega
    03 # AX MOV  10 INT                     \ SET MODE 3
    1112 # AX MOV  0 # BL MOV  10 INT       \ Load 8X8 font
    1200 # AX MOV  20 # BL MOV  10 INT      \ Load new printscreen
    1 # AH MOV  707 # CX MOV  10 INT        \ LOAD CURSOR SCAN LINES
    3D4 # DX MOV  0A # AL MOV  [DX] BYTE OUT \ set cursor
    FWD, THEN,
    DX INC
    6 # AL MOV  [DX] OUT
    RET
END-CODE

0 0 IN/OUT
CODE unset-ega
    03 # AX MOV  10 INT  RET  END-CODE
#THEN

0 0 IN/OUT
: setup-vid
EGA #IF
    set-ega
    CTASK @ 12 + CS: OFF    \ home cursor
#ELSE
    40 49 C@L 7 = IF 3B4 crtport ! B000 vidseg ! THEN \ MONOCHROME
    40 50 C@L 40 51 C@L GOTOXY
    vidseg @  c/l l/s 1- * 2* 1+ C@L  CTASK @ 14 + CS: !
#THEN
;

 CODE unsetup-vid
EGA #IF
    CALL' CLS
    CALL' unset-ega
    DX DX XOR
#ELSE
    CTASK [] BX MOV
    CS: 12 +[BX] AX MOV  \ cursor offset
    c/l # BX MOV
    DX DX XOR
    AX 1 SAR
    BX IDIV
    AL DH MOV
#THEN
    2 # AH MOV
    BH BH XOR
    10 INT
    RET
END-CODE \ unsetup-vid

CODE scrmove  ( source dest wordCount -- )
    BX POP
    CX POP
    DI POP
    SI POP
    LOOP IF,
        DS PUSHSEG
VID-DELAY #IF
        B800 # vidseg [] CMP  =0 IF,
            3DA # DX MOV
            BEGIN,
                BYTE [DX] IN
                8 # AL TEST
            =0 ~ UNTIL,
            DX DEC
            DX DEC
            21 # AL MOV
            BYTE [DX] OUT
        THEN,
#THEN
        vidseg [] AX MOV
        AX DS >SEG
        AX ES >SEG
        REPZ MOVS
        DS POPSEG
VID-DELAY #IF
        B800 # vidseg [] CMP  =0 IF,
            3D8 # DX MOV
            29 # AL MOV
            BYTE [DX] OUT
        THEN,
#THEN
    THEN,
    BX JMPI
END-CODE \ scrmove

2 0 IN/OUT
CODE scrfill ( source wordCount -- )
    vidseg [] ES >SEG
    20 # BYTE ES: [BX] MOV
    CTASK [] DI MOV
    CS: 14 +[DI] CL MOV  \ style
    CL ES: 1 +[BX] MOV
    BX PUSH
    BX INC
    BX INC
    BX PUSH
    AX DEC
    AX PUSH
    CALL' scrmove
    RET
END-CODE \ scrfill

0 0 IN/OUT
: scrollup  c/l 2*  0  c/l l/s 1- * scrmove
    c/l l/s 1- * 2*  c/l    scrfill
    c/l l/s 1- * 2*  CTASK @ 12 + CS: ! ( set cursor ) ;

0 2 IN/OUT
: ?XY     CTASK @ 12 + CS: @  2/  0 c/l UM/MOD ;

1 0 IN/OUT
: FOREGROUND 0F AND CTASK @ 14 + TUCK CS: @ F0 AND OR SWAP CS: ! ;

1 0 IN/OUT
: BACKGROUND 7 AND 4 << CTASK @ 14 + TUCK CS: @ 0F AND OR SWAP CS: ! ;


: EMIT
    CTASK @ 12 + CS: @  c/l l/s * 2* >= IF scrollup THEN
    vidseg @ CTASK @ 12 + CS: @ C!L
    CTASK @ 14 + CS: @ vidseg @ CTASK @ 12 + CS: @ 1+ C!L
    CTASK @ 12 + CS: @ 2+ storecursor  PAUSE ;

: CR
    CTASK @ 12 + CS: @
    c/l 2*  U/  1+  c/l 2*  *
    DUP c/l l/s * 2* = IF DROP scrollup  CTASK @ 12 + CS: @ THEN
    storecursor  PAUSE ;

: SPACES
    DUP 0> IF
        c/l l/s * 2*  CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
        0 DO BL EMIT LOOP ELSE
            CTASK @ 12 + CS: @  SWAP 2DUP scrfill
        2* + storecursor  PAUSE
        THEN
    ELSE   DROP
    THEN
;


2 1 IN/OUT
CODE (type) ( AX has count, BX has string, result is cursor position )
    BX SI MOV
    CTASK [] BX MOV
    CS: 12 +[BX] DI MOV \ cursor
    AX CX MOV
    CS: 14 +[BX] AH MOV \ style
    vidseg [] ES >SEG
    LOOP IF,
        BEGIN,
            BYTE LODS
            STOS
        LOOP ~ UNTIL,
    THEN,
    DI AX MOV       \ final cursor position
    RET
END-CODE \ (type)

: TYPE
    c/l l/s * 2*  CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
        0 ?DO COUNT EMIT LOOP DROP
    ELSE
        (type) storecursor PAUSE
    THEN ;

2 1 IN/OUT
CODE (cs:type) ( AX has count, BX has string, result is cursor position)
    BX SI MOV
    CTASK [] BX MOV
    CS: 12 +[BX] DI MOV \ cursor
    AX CX MOV
    CS: 14 +[BX] AH MOV \ style
    vidseg [] ES >SEG
    LOOP IF,
        BEGIN,
            CS: BYTE LODS
            STOS
        LOOP ~ UNTIL,
    THEN,
    DI AX MOV       \ final cursor position
    RET
END-CODE \ (cs:type)

: CS:TYPE
    c/l l/s * 2* CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
        0 ?DO CS: COUNT EMIT LOOP DROP
    ELSE
        (cs:type) storecursor PAUSE
    THEN ;


0 0 IN/OUT
: CLS  0  c/l l/s *  scrfill  0 storecursor ;

0 1 IN/OUT
CODE ?TERMINAL
    CALL' PAUSE     \ allow another task to execute
    1 # AH MOV
    16 INT
    0 # AX MOV
    =0 ~ IF, AX DEC  THEN,
    RET
END-CODE \ ?TERMINAL

: PAD CTASK @ 16 + CS: @ ;


: KEY  BEGIN ?TERMINAL  CTASK @ 12 + CS: @ setcursor UNTIL
    0 8 BDOS
    PAUSE
    nocursor ;

 \ EXPECT
FIND SPAN #IF DROP #ELSE VARIABLE SPAN #THEN

0 0 IN/OUT
: bu  CTASK @ 12 + CS: @ 2- DUP storecursor BL EMIT storecursor -1 SPAN +! ;

DECIMAL

: EXPECT
    inexpect SEMA       \ too hard if two or more tasks want input at once!
    SPACE
    >R SPAN OFF
    BEGIN
        SPAN @ R@ < WHILE       \ more room on line
        KEY  CASE
        27 OF BEGIN SPAN @ 0> WHILE bu REPEAT  ENDOF
        8  OF SPAN @ 0> IF bu THEN ENDOF
        13 OF BL EMIT
              R> DROP DROP
              inexpect PHORE
              EXIT ENDOF
        ( ELSE ) DUP EMIT
                 OVER SPAN @ + C!
                 1 SPAN +!
        0 ENDCASE
    REPEAT
    inexpect PHORE
    R> 2DROP ;


 \ TASK CREATION
HEX
H: TASK                          \ values after INIT-TASKS:
   CSEG FORCE CREATE HERE E92E , \ DISP 0 -- JMP ( task asleep )
   DSEG CTASK @ ,  CTASK !    \     02 -- relative addr nxt task
   user @ ,                   \     04 -- size of user area (not used?)
   0 ,                        \     06 -- SS register contents
   user @ pssize 10 * + ,     \     08 -- SP register contents
   user @ pssize 10 * + rssize + , \     0A -- BP register contents
   ,                          \     0C -- PC contents
\ the following fields are for per-task variables
\ and could be selectively elimiated if not needed if space is
\ at a premium.  In that case, offsets may need to be adjusted
\ for words which use latter fields.
   0 ,                        \     0E -- Message list
   0 ,                        \     10 -- Timer
   0 ,                        \     12 -- Cursor location
   7 ,                        \     14 -- character attribute (style)
   DSEG HERE 80 ALLOT 20 + ,  \     16 -- PAD, a per-task work area
;
0 #IF
Initially, DISP 2 has absolute address of next task.
This values as well as DISP 6 get
filled in by INIT-TASKS when application is run.
#THEN

CSEG FORCE  HERE  CREATE MAIN-TASK  \ Give it a name
DSEG CTASK !                    \ Task list points to it
80CD ,                          \ DISP 0 -- INT 80 (task awake)
   0 ,                          \ 02 -- relative addr next task
   0 ,                          \ 04 -- NOT USED
   0 ,                          \ 06 -- SS register contents
   0 ,                          \ 08 -- SP register contents
   0 ,                          \ 0A -- BP register contents
   0 ,                          \ 0C -- PC contents
   0 ,                          \ 0E -- Message list
   0 ,                          \ 10 -- Timer
   0 ,                          \ 12 -- Cursor Location
   7 ,                          \ 14 -- Style
   DSEG HERE 80 ALLOT 20 + ,    \ 16 -- PAD, a per-task work area
0 #IF
DISP-2, 6, and 12 get filled in by INIT-TASK.  -8 -0A and -0C
are filled by first task swap (which is done by INIT-TASK).
#THEN

 \ TASK INITIALIZATION
0 0 IN/OUT
: INIT-TASKS \ This MUST be executed to start multitasking
    CTASK @
    BEGIN ?DUP WHILE  \ for each task DO:
        2+ DUP CS: @ IF  \ one follows, this isnt main task
            DUP 8 + CS: @ 10 + 4 >>  GET
         OVER 4 + CS: ! \ stackseg
            DUP CS: @ TUCK   \ next task
        ELSE
            0 SWAP CTASK @ \ next task is head of list
        THEN
        OVER - 2- SWAP CS: !
    REPEAT
    MAIN-TASK CTASK !
    setup-vid
    ?SS: MAIN-TASK 6 + CS: !    \ sets main task stack segment
    start-timer
    MULTI ( GO!!! ) ;

 \ TASK DISPATCHER
CODE PAUSE
    0 # ?multi [] CMP
    =0 IF, RET THEN,
    CTASK [] BX MOV         \ current task
    CS: 0C +[BX] POP        \ save PC
    BP CS: 0A +[BX] MOV     \ save BP
    SP CS: 08 +[BX] MOV     \ save SP
    CS: 2 +[BX] BX ADD
    4 # BX ADD
    CLI                \ no ints during dispatch!
    BX JMPI  ( dispatch )
END-CODE \ PAUSE

0 #IF
Tasks are linked together so that jumping to a task will cause
jumping to the next if it is asleep, or doing an INT 80 if it
is awake.  Thanks to Henry Laxen's Forth 83 model for the
technique.
#THEN

L: start-task ( the INT80 routine )
    BX POP
    BX DEC
    BX DEC                  \ Pointer to the task
    CS: 6 +[BX] SS >SEG     \ restore stack segment
    CS: 8 +[BX] SP MOV      \ restore SP
    STI                     \ Interrupts are safe now
    CS: 0A +[BX] BP MOV     \ restore BP
    BX  CTASK [] MOV        \ current task
    CS: 0C +[BX] JMPI       \ go!
FORTH \ start-task
0 #IF
This code starts up a new task by setting up all registers,
fixing CTASK and USERP, and jumping to where we left off.
#THEN

 \ TASK MANAGEMENT
: SINGLE  ?multi OFF ;

: MULTI   ?multi ON
    ?CS: start-task 80 set-handler  \ install interrupt vector
    PAUSE  \ start with a task swap
;

1 0 IN/OUT
: WAKE  80CD CS: <- ;

1 0 IN/OUT
\ the 2e prefix byte (CS override) makes the jmp instruction 4 bytes long
: SLEEP (  task -- )   E92E CS: <- ;

1 1 IN/OUT
: WAITING?  10 + CS: @ 0<> ;

0 0 IN/OUT
: STOP  CTASK @ SLEEP PAUSE ;

0 1 IN/OUT
: ACTIVE-TASKS
    0 MAIN-TASK
    BEGIN
        DUP WAITING? IF SWAP 1+ SWAP ELSE
            DUP CS: @ 80CD = IF SWAP 1+ SWAP THEN THEN \ check for active
        DUP 2+ CS: @ + 4 + \ address of next task
    DUP MAIN-TASK = UNTIL     \ Loop until back to start
    DROP ( task address )
;

 \ MESSAGE PASSING
0 1 IN/OUT
: MESSAGE?  CTASK @ 0E + CS: @ ;

0 1 IN/OUT
: GET-MESSAGE
  BEGIN MESSAGE? ?DUP 0= WHILE STOP REPEAT
  DUP  0 @L  CTASK @ 0E + CS: !  \ Unlink message
;

1 1 IN/OUT
: MESSAGES
    0 SWAP 0E + CS: @ ?DUP IF
        BEGIN SWAP 1+ SWAP  0 @L  ?DUP 0= UNTIL
    THEN ;

2 0 IN/OUT
: SEND-MESSAGE
    OVER 0 SWAP 0 !L        \ set message's next field to NIL
    DUP WAITING? NOT IF DUP WAKE THEN \ fire up receiving task
                                \ unless waiting for timer
    0E + DUP CS: @ ?DUP IF  \ Existing messages in queue
        NIP
        BEGIN DUP 0 @L ?DUP WHILE NIP REPEAT \ find end of list
        0 !L  \ store message at end of list
    ELSE
        CS: !     \ no existing messages, put at head of queue.
    THEN
    PAUSE ;  \ Give it a chance to run

 \ control-break handler
\ always gets control and (currently) dumps task information

2VARIABLE cb_save

1B CONSTANT cb_int

0 0 IN/OUT
: cbt
    CLS
    SINGLE
    end-timer
    ." Task statistics: "
    MAIN-TASK \ start with first
    BEGIN CR
        HEX DUP 0 <# # # # # #> TYPE SPACE \ address
        DUP WAITING? IF ." Waiting " DUP 10 + CS: @ . ." ticks" ELSE
            DUP CS: @ 80CD = IF ." Active" ELSE ." Sleeping" THEN THEN
        DUP 2+ CS: @ + 4 + \ address of next task
    DUP MAIN-TASK = UNTIL     \ Loop until back to start
    DROP ( task address )
EGA #IF
    CR ." Hit any key when finished"    KEY DROP
#THEN
    unsetup-vid
    bye
;


' cbt TASK cb-task


L: cb_handler ( actual interrupt handler )
      80CD # CS: cb-task [] MOV \ wake cb task
    STI
    IRET FORTH


 \ timer
1C CONSTANT t_int               \ timer interupt vector number
CSEG FORCE
CREATE t_save 4 ALLOT           \ original interupt vector
L: t_handler
    PUSHF CS: t_save CALLF    \ do original functions
    BX PUSH
    MAIN-TASK # BX MOV ( start of list )
    BEGIN,
        CS: 0 # 10 +[BX] CMP =0 ~ IF, ( non_zero time )
            CS: 10 +[BX] DEC  ( count down )
            =0 IF, 80CD # CS: [BX] MOV THEN, ( wake task )
        THEN,
        CS: 2 +[BX] BX ADD
        4 # BX ADD ( next task )
        MAIN-TASK # BX CMP
    =0 UNTIL, ( back at start? )
    BX POP
    IRET
FORTH \ t_handler

\ timer start and end                          08:09 11/18/85

: start-timer  \ and control break handler
    t_int get-handler  t_save CS: 2!
    ?CS: t_handler t_int set-handler
    cb_int get-handler cb_save 2!
    ?CS: cb_handler cb_int set-handler
;

: end-timer
    t_save CS: 2@  t_int set-handler
    cb_save 2@ cb_int set-handler
;

2 0 IN/OUT
: TIME-OUT ( ticks task -- )  DUP SLEEP 10 + CS: ! ;

1 0 IN/OUT
: WAIT ( ticks -- ) CTASK @ TIME-OUT PAUSE ;

DSEG 0A = #IF DECIMAL #THEN