--- /dev/null
+
+TITLE PROCESS-HACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES
+.GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS
+.GLOBAL TBINIT,APLQ,PVSTOR,SPSTOR
+
+MFUNCTION PROCESS,SUBR
+
+ ENTRY 1
+ GETYP A,(AB) ;GET TYPE OF ARG
+ ;MUST BE SOME APPLIABLE TYPE
+ PUSHJ P,APLQ
+ JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE
+OKFUN:
+
+ MOVEI A,TPLNT/2 ;SMALL STACK PARAMETERS
+ MOVEI B,PLNT/2
+ PUSHJ P,ICR ;CREATE A NEW PROCESS
+ MOVE C,TPSTO+1(B) ;GET ITS SRTACK
+ PUSH C,[TENTRY,,TOPLEV]
+ PUSH C,[1,,0] ;TIME
+ PUSH C,[0]
+ PUSH C,SPSTO(B)
+ PUSH C,PSTO+1(B)
+ MOVE D,C
+ ADD D,[3,,3]
+ PUSH C,D ;SAVED STACK POINTER
+ PUSH C,[SUICID]
+ MOVEM C,TPSTO+1(B) ;STORE NEW TP
+ HRRI D,1(C) ;MAKE A TB
+ HRLI D,400002 ;WITH A TIME
+ MOVEM D,TBINIT+1(B)
+ MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START
+ MOVE C,(AB) ;STORE ARG
+ MOVEM C,RESFUN(B) ;INTO PV
+ MOVE C,1(AB)
+ MOVEM C,RESFUN+1(B)
+ MOVEI 0,RUNABL
+ MOVEM 0,PSTAT+1(B)
+ JRST FINIS
+
+REPEAT 0,[
+MFUNCTION RETPROC,SUBR
+; WHO KNOWS WHAT THIS SHOULD REALLY DO
+;PROBABLY, JUST AN EXIT
+;FOR NOW, PRINT OUT AN ERROR MESSAGE
+ ERRUUO EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS
+
+
+
+
+
+
+
+MFUNCTION RESUME,FSUBR
+;RESUME IS CALLED WITH TWO ARGS
+;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED
+;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS
+; (THE PARENT) IS ITSELF RESUMED
+;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS
+;PLUGGED IN
+;
+; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE
+
+ ENTRY 1
+ HRRZ C,@1(AB) ;GET CDR ADDRESS
+ JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD
+ HLLZ A,(C) ;GET CDR TYPE
+ CAME A,$TATOM ;ATOMIC?
+ JRST RES2 ;NO, MUST EVAL TO GET FUNCTION
+ MOVE B,1(C) ;YES
+ PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE
+ CAMN A,$TUNBOUND ;GLOBALLY UNBOUND?
+ JRST LFUN ;YES, TRY FOR LOCAL VALUE
+RES1: MOVE PVP,PVSTOR+1
+ MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS
+ MOVEM B,RESFUN+1(PVP)
+
+ HRRZ C,1(AB) ;GET CAR ADDRESS
+ PUSH TP,(C) ;PUSH PROCESS FORM
+ PUSH TP,1(C)
+ JSP E,CHKARG ;CHECK FOR DEFERED TYPE
+ ;INSERT CHECKS FOR PROCESS FORM
+ MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH
+ ; PROCESSES
+ JRST FINIS
+
+RES2: PUSH TP,(C) ;PUSH FUNCTION ARG
+ PUSH TP,1(C)
+ JSP E,CHKARG ;CHECK FOR DEFERED
+ MCALL 1,EVAL ;EVAL TO GET FUNCTION
+ JRST RES1
+
+LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION
+ JRST RES1
+
+NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND
+ JRST RES1
+]
+
+; PROCHK - SETUP LAST RESUMER SLOT
+
+PROCHK: MOVE PVP,PVSTOR+1
+ CAME B,MAINPR ; MAIN PROCESS?
+ MOVEM PVP,LSTRES+1(B)
+ POPJ P,
+
+; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS
+; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS
+; RESFUN
+; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES)
+
+
+MFUNCTION RESUME,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,[-4,,0]
+ JRST TMA
+ CAMGE AB,[-2,,0]
+ JRST CHPROC ; VALIDITY CHECK ON PROC
+ MOVE PVP,PVSTOR+1
+ SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS?
+ JRST NORES ; NO, COMPLAIN
+GOTPRO: MOVE C,AB
+ CAMN B,PVSTOR+1 ; DO THEY DIFFER?
+ JRST RETARG
+ MOVE A,PSTAT+1(B) ; CHECK STATE
+ CAIE A,RUNABL ; MUST BE RUNABL
+ CAIN A,RESMBL ; OR RESUMABLE
+ JRST RESUM1
+NOTRES:
+NOTRUN: ERRUUO EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE
+
+RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP
+ MOVEI A,RESMBL ; GET NEW STATE
+ MOVE D,B ; FOR SWAP
+STRTN: JSP C,SWAP ; SWAP THEM
+ MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE
+ MOVE PVP,PVSTOR+1
+ MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED
+ MOVEI 0,RUNING
+ MOVEM 0,PSTAT+1(PVP) ; NEW STATE
+ MOVE C,ABSTO+1(E) ; OLD ARGS
+ CAIE A,RESMBL
+ JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN
+RETARG: MOVE A,(C)
+ MOVE B,1(C) ; RETURN
+ JRST FINIS
+
+DORUN: PUSH TP,RESFUN(PVP)
+ PUSH TP,RESFUN+1(PVP)
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 2,APPLY
+ PUSH TP,A ; CALL SUICIDE WITH THESE ARGS
+ PUSH TP,B
+ MCALL 1,SUICID ; IF IT RETURNS, KILL IT
+ JRST FINIS
+
+CHPROC: GETYP A,2(AB)
+ CAIE A,TPVP
+ JRST WTYP2
+ MOVE B,3(AB)
+ JRST GOTPRO
+
+NORES: ERRUUO EQUOTE NO-PROCESS-TO-RESUME
+
+; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT
+
+MFUNCTION SUICIDE,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ HLRE A,AB
+ ASH A,-1 ; DIV BY 2
+ AOJE A,NOPROC ; NO PROCESS GIVEN
+ AOJL A,TMA
+ GETYP A,2(AB) ; MAKE SURE OF PROCESS
+ CAIE A,TPVP
+ JRST WTYP2
+ MOVE C,3(AB)
+ JRST SUIC2
+
+NOPROC: MOVE PVP,PVSTOR+1
+ SKIPN C,LSTRES+1(PVP)
+ MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN
+SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF
+ JRST SUSELF
+ MOVE B,PSTAT+1(C)
+ CAIE B,RUNABL
+ CAIN B,RESMBL
+ JRST .+2
+ JRST NOTRUN
+ MOVE B,C
+ PUSHJ P,PROCHK
+ MOVE D,B ; RESTORE NEWPROCESS
+ MOVEI A,DEAD
+ JRST STRTN
+
+SUSELF: ERRUUO EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF
+
+
+MFUNCTION RESER,SUBR,RESUMER
+
+ ENTRY
+ MOVE B,PVSTOR+1
+ JUMPGE AB,GTLAST
+ CAMGE AB,[-2,,0]
+ JRST TMA
+
+ GETYP A,(AB) ; CHECK FOR PROCESS
+ CAIE A,TPVP
+ JRST WTYP1
+ MOVE B,1(AB) ; GET PROCESS
+GTLAST: MOVSI A,TFALSE ; ASSUME NONE
+ SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS
+ JRST FINIS
+ MOVSI A,TPVP ; GET TYPE
+ JRST FINIS
+
+; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK
+
+MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ
+
+ ENTRY 2
+
+ GETYP A,2(AB) ; 2D ARG MUST BE PROCESS
+ CAIE A,TPVP
+ JRST WTYP2
+
+ MOVE B,3(AB) ; GET PROCESS
+ CAMN B,PVSTOR+1 ; SKIP IF NOT ME
+ JRST BREAKM
+ MOVE A,PSTAT+1(B) ; CHECK STATE
+ CAIE A,RESMBL ; BEST BE RESUMEABLE
+ JRST NOTRUN
+ MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME
+ MOVE D,TPSTO+1(B) ; STACK POINTER
+ MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME
+ MOVEM E,SPSAV(C)
+ MOVEI E,CALLEV ; FUNNY PC
+ MOVEM E,PCSAV(C)
+ MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES
+ MOVEM E,PSAV(C)
+ PUSH D,[0] ; ALLOCATES SOME SLOTS
+ PUSH D,[0]
+ PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED
+ PUSH D,1(AB)
+ MOVEM D,TPSAV(C)
+ HRRI E,-1(D) ; BUILD UP ARG POINTER
+ HRLI E,-2
+ PUSH D,[TENTRY,,BREAKE]
+ PUSH D,C ; OLD TB
+ PUSH D,E ; NEW ARG POINTER
+REPEAT 4,PUSH D,[0] ; OTHER SLOTS
+ MOVEM D,TPSTO+1(B)
+ MOVEI C,(D) ; BUILD NEW AB
+ AOBJN C,.+1
+ MOVEM C,TBSTO+1(B) ; STORE IT
+ MOVE A,2(AB) ; RETURN PROCESS
+ MOVE B,3(AB)
+ JRST FINIS
+
+MQUOTE BREAKER
+
+BREAKE:
+CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT)
+ MOVEM B,-2(TP)
+ MCALL 1,EVAL
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+BREAKM: ERRUUO EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE
+
+; FUNCTION TOP PUT PROCESS IN 1 STEP MODE
+
+MFUNCTION 1STEP,SUBR
+ PUSHJ P,1PROC
+ MOVE PVP,PVSTOR+1
+ MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS
+ JRST FINIS
+
+; FUNCTION TO UNDO ABOVE
+
+MFUNCTION %%FREE,SUBR,FREE-RUN
+ PUSHJ P,1PROC
+ MOVE PVP,PVSTOR+1
+ CAME PVP,1STEPR+1(B)
+ JRST FNDBND
+ SETZM 1STEPR+1(B)
+ JRST FINIS
+
+FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER?
+ JRST NOTMIN ; YES, COMPLAIN
+ MOVE D,B ; COPY PROCESS
+ ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH
+ HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK
+
+FNDLP: GETYP 0,(C) ; IS THIS A TBVL?
+ CAIN 0,TBVL
+ CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT
+ JRST FNDNXT
+ SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER?
+ JRST FNDNXT
+ MOVE PVP,PVSTOR+1
+ CAME PVP,3(C) ; IS IT ME?
+ JRST NOTMIN
+ SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER
+ JRST FINIS
+FNDNXT: HRRZ C,(C) ; NEXT BINDING
+ JUMPN C,FNDLP
+
+NOTMIN: MOVE C,$TCHSTR
+ MOVE D,CHQUOTE NOT-YOUR-1STEPEE
+ PUSHJ P,INCONS
+ MOVSI A,TFALSE
+ JRST FINIS
+
+1PROC: ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TPVP
+ JRST WTYP1
+ MOVE B,1(AB)
+ MOVE A,(AB)
+ POPJ P,
+
+; FUNCTION TO RETRUN THE MAIN PROCESS
+
+MFUNCTION MAIN%%,SUBR,MAIN
+ ENTRY 0
+
+ MOVE B,MAINPR
+MAIN1: MOVSI A,TPVP
+ JRST FINIS
+
+; FUNCTION TO RETURN THE CURRENT PROCESS
+
+MFUNCTION ME,SUBR
+ ENTRY 0
+
+ MOVE B,PVSTOR+1
+ JRST MAIN1
+
+; FUNCTION TO RETURN THE STATE OF A PROCESS
+
+MFUNCTION STATE,SUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TPVP
+ JRST WTYP1
+ MOVE A,1(AB) ; GET PROCESS
+ MOVE A,PSTAT+1(A)
+ MOVE B,@STATES(A) ; GET STATE
+ MOVSI A,TATOM
+ JRST FINIS
+
+STATES:
+ IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED]
+ MQUOTE A
+ TERMIN
+
+
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff