File psl-1983/3-1/tests/20/dec20-patches.sl artifact f3fb26b511 part of check-in 255e9d69e6


% DEC20-PATCHES.SL
% to convert to Portable, 2 reg for LINK model
% From DEC20-Asm.RED
% These will now be simpler than 20, just JRST
% Should even be InternalEntry for efficiency, avoid circular defns
% Right now, expect same as !%Store!-JCALL would install

(SETQ UndefinedFunctionCellInstructions!*
	       '((!*JCALL  UndefinedFunction)))
                       
(SETQ LambdaFunctionCellInstructions!* 
	       '((!*JCALL  CompiledCallingInterpreted)))

(Put 'LinkReg 'RegisterName 12)
(Put 'NargReg 'RegisterName 13)

% From PC:Common-Cmacros.sl

(de MakeLinkRegs(Fn Nargs)
  (cond ((FlagP Fn 'NoLinkage) NIL)
      (T (list (list '!*Move (list 'IdLoc FunctionName) '(reg LinkReg) )
               (list '!*Move (list 'Wconst NumberofArguments) '(reg NargReg) )
      ))))

(FLAG '(IDapply0 IDapply1 IDapply2 IDapply3 IDapply4) 'NoLinkage)

(de !*Link (FunctionName FunctionType NumberOfArguments)
  (cond ((FlagP FunctionName 'ForeignFunction)
	     (list  (list '!*ForeignLink
		             FunctionName
		             FunctionType
		             NumberOfArguments)))
   (t (append (MakeLinkRegs FunctionName NumberofArguments)
              (list (list '!*Call FunctionName))))))


(de !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments)
  (cons (list '!*DeAlloc DeAllocCount)
	(cond ((FlagP FunctionName 'ForeignFunction)
	       (list (list '!*ForeignLink
			   FunctionName
			   FunctionType
			   NumberOfArguments)
		     '(!*Exit 0)))
    (t (Append (MakeLinkRegs FunctionName NumberofArguments)
               (list (list '!*JCall FunctionName)))))))

(DefList '((IDApply0  (
                (!*move (Wconst 0) (reg NargReg))
                (!*move (reg 1) (reg LinkReg))
      %         (!*Wtimes2 (reg 1) (Wconst AddressingUnitsPerFunctionCell))
		(pushj (reg st) (Indexed (reg 1) (WArray SymFnc)))))
	   (IDApply1  (
                (!*move (Wconst 1) (reg NargReg))
                (!*move (reg 2) (reg LinkReg))
      %	        (!*Wtimes2 (reg 2) (Wconst AddressingUnitsPerFunctionCell))
		(pushj (reg st) (Indexed (reg 2) (WArray SymFnc)))))
	   (IDApply2  (
                (!*move (Wconst 2) (reg NargReg))
                (!*move (reg 3) (reg LinkReg))
      %	        (!*Wtimes2 (reg 3) (Wconst AddressingUnitsPerFunctionCell))
		(pushj (reg st) (Indexed (reg 3) (WArray SymFnc)))))
	   (IDApply3  (
                (!*move (Wconst 3) (reg NargReg))
                (!*move (reg 4) (reg LinkReg))
      %	        (!*Wtimes2 (reg 4) (Wconst AddressingUnitsPerFunctionCell))
		(pushj (reg st) (Indexed (reg 4) (WArray SymFnc)))))
	   (IDApply4  (
                (!*move (Wconst 4) (reg NargReg))
                (!*move (reg 5) (reg LinkReg))
      %	        (!*Wtimes2 (reg 5) (Wconst AddressingUnitsPerFunctionCell))
		(pushj (reg st) (Indexed (reg 5) (WArray SymFnc)))))
)   'OpenCode)


(DefList '((IDApply0  (
                (!*move (Wconst 0) (reg NargReg))
                (!*move (reg 1) (reg LinkReg))
	      % (!*wtimes2 (reg 1) (Wconst AddressingUnitsPerFunctionCell))
		(jrst (Indexed (reg 1) (WArray SymFnc)))))
	   (IDApply1 (
                (!*move (Wconst 1) (reg NargReg))
                (!*move (reg 2) (reg LinkReg))
	      % (!*wtimes2 (reg 2) (Wconst AddressingUnitsPerFunctionCell))
		(jrst (Indexed (reg 2) (WArray SymFnc)))))
	   (IDApply2 (
                (!*move (Wconst 2) (reg NargReg))
                (!*move (reg 3) (reg LinkReg))
	      % (!*wtimes2 (reg 3) (Wconst AddressingUnitsPerFunctionCell))
		(jrst (Indexed (reg 3) (WArray SymFnc)))))
	   (IDApply3 (
                (!*move (Wconst 3) (reg NargReg))
                (!*move (reg 4) (reg LinkReg))
	      % (!*wtimes2 (reg 4) (Wconst AddressingUnitsPerFunctionCell))
		(jrst (Indexed (reg 4) (WArray SymFnc)))))
	   (IDApply4 (
                (!*move (Wconst 4) (reg NargReg))
                (!*move (reg 5) (reg LinkReg))
	      % (!*wtimes2 (reg 5) (Wconst AddressingUnitsPerFunctionCell))
		(jrst (Indexed (reg 5) (WArray SymFnc)))))
)	 'ExitOpenCode)

% From PC:lap-to-asm.red

(de DataPrintUndefinedFunctionCell ()
  (Prog (OldOut)
    (setq OldOut (WRS DataOut!*))
    (foreach X in (Pass1Lap UndefinedFunctionCellInstructions!*) do
	(ASMOutLap1 X))
    (WRS OldOut)))

(DSKIN "PT:P-LAMBIND.SL")

% new SYSLISP bug, perhaps useful refefined it?

(off usermode)

(dm for(u) ( MkFor1 u))


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]