Artifact f3fb26b511f3c825ab901ad216db6cc2bd4e3e0cd91cafe8d24bf6c3e411d462:

• File psl-1983/3-1/tests/20/dec20-patches.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4331) [annotate] [blame] [check-ins using] [more...]

% 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))