MUDDLE/create.14

   1
   2 TITLE PROCESS-HACKER FOR MUDDLE
   3
   4 RELOCATABLE
   5
   6 .INSRT MUDDLE >
   7
   8 .GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC
   9
  10 MFUNCTION CREATE,SUBR
  11
  12         ENTRY 1
  13         GETYP   A,(AB)          ;GET TYPE OF ARG
  14                                 ;MUST BE SOME APPLIABLE TYPE
  15         CAIE    A,TSUBR         ;SUBR?
  16         CAIN    A,TEXPR         ;EXPR?
  17         JRST    OKFUN
  18         CAIE    A,TFSUBR                ;FSUBR?
  19         CAIN    A,TFUNARG               ;FUNARG?
  20         JRST    OKFUN
  21         CAIE    A,TFIX          ;CALL TO GET? (ALLOWING THIS IS QUESTIONABLE)
  22         JRST    NAPT            ;NO, ERROR - NON-APPLIABLE TYPE
  23 OKFUN:
  24
  25         PUSHJ   P,ICR   ;CREATE A NEW PROCESS
  26         MOVE    C,TPSTO+1(B)    ;GET ITS SRTACK
  27         PUSH    C,[TENTRY,,RETPROC]
  28         PUSH    C,[1,,0]        ;TIME
  29         PUSH    C,[0]
  30         PUSH    C,SPSTO+1(B)
  31         PUSH    C,PSTO+1(B)
  32         MOVE    D,C
  33         ADD     D,[3,,3]
  34         PUSH    C,D     ;SAVED STACK POINTER
  35         PUSH    C,PPSTO+1(B)    ;
  36         PUSH    C,[RETPROC]
  37         MOVEM   C,TPSTO+1(B)    ;STORE NEW TP
  38         HRRI    D,1(C)  ;MAKE A TB
  39         HRLI    D,2     ;WITH A TIME
  40         MOVEM   D,TBINIT+1(B)
  41         MOVEM   D,TBSTO+1(B)    ;SAVE ALSO FOR SIMULATED START
  42         MOVE    C,(AB)  ;STORE ARG
  43         MOVEM   C,RESFUN(B)     ;INTO PV
  44         MOVE    C,1(AB)
  45         MOVEM   C,RESFUN+1(B)
  46         JRST FINIS
  47
  48 MFUNCTION       RETPROC,SUBR
  49 ; WHO KNOWS WHAT THIS SHOULD REALLY DO
  50 ;PROBABLY, JUST AN EXIT
  51 ;FOR NOW, PRINT OUT AN ERROR MESSAGE
  52         PUSH    TP,$TATOM
  53         PUSH    TP,MQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS
  54         JRST    CALER1\r
  55
  56
  57
  58
  59
  60
  61 MFUNCTION RESUME,FSUBR
  62 ;RESUME IS CALLED WITH TWO ARGS
  63 ;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED
  64 ;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS
  65 ;    (THE PARENT) IS ITSELF RESUMED
  66 ;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS
  67 ;PLUGGED IN
  68 ;
  69 ; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE
  70
  71         ENTRY   1
  72         HRRZ    C,@1(AB)                ;GET CDR ADDRESS
  73         JUMPE   C,NOFUN         ;IF NO SECOND ARG, SUPPLY STANDARD
  74         HLLZ    A,(C)           ;GET CDR TYPE
  75         CAME    A,$TATOM                ;ATOMIC?
  76         JRST    RES2            ;NO, MUST EVAL TO GET FUNCTION
  77         MOVE    B,1(C)          ;YES
  78         PUSHJ   P,IGVAL         ;TRY TO GET GLOBAL VALUE
  79         CAMN    A,$TUNBOUND     ;GLOBALLY UNBOUND?
  80         JRST    LFUN            ;YES, TRY FOR LOCAL VALUE
  81 RES1:   MOVEM   A,RESFUN(PVP)   ;STORE IN THIS PROCESS
  82         MOVEM   B,RESFUN+1(PVP)
  83
  84         HRRZ    C,1(AB)         ;GET CAR ADDRESS
  85         PUSH    TP,(C)          ;PUSH PROCESS FORM
  86         PUSH    TP,1(C)
  87         JSP     E,CHKARG        ;CHECK FOR DEFERED TYPE
  88                                 ;INSERT CHECKS FOR PROCESS FORM
  89         MCALL   1,EVAL          ;EVAL PROCESS FORM WHICH WILL SWITCH
  90                                 ; PROCESSES
  91         JRST    FINIS
  92
  93 RES2:   PUSH    TP,(C)          ;PUSH FUNCTION ARG
  94         PUSH    TP,1(C)
  95         JSP     E,CHKARG        ;CHECK FOR DEFERED
  96         MCALL   1,EVAL          ;EVAL TO GET FUNCTION
  97         JRST    RES1
  98
  99 LFUN:   HRRZ    C,1(AB)         ;GET CDR ADDRESS
 100         PUSH    TP,(C)
 101         PUSH    TP,1(C)
 102         MCALL   1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION
 103         JRST    RES1
 104
 105 NOFUN:  MOVSI   A,TUNBOUND      ;MAKE RESUME FUNCTION UNBOUND
 106         JRST    RES1
 107
 108 END
 109 \f\ 3\f