Artifact f7e81411616150b4067e72278fb193adb690038d37f3bc1b88a00d3006eb9b1b:

• File psl-1983/20-util/jsys.red — 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: 13344) [annotate] [blame] [check-ins using] [more...]

%
% JSYS.RED - Simple XJSYS function
% 
% Author:      Martin L. Griss 
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        8 March 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.UTIL>JSYS.RED.9, 18-May-82 13:24:36, Edit by BENSON
%  Made XJSYSn OpenCode'ed
%/ Changed FILNAM->FileName, due to GLOBAL conflict
%/ Changed JSYS calls, so LIST(..) rather than '(..) used
%/ Changed for V3:JSYS
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  <PSL.UTIL>JSYS.RED.2, 18-Mar-82 21:49:32, Edit by GRISS
%  Converted to V3
%. M. Griss 3:32pm  Saturday, 7 November 1981
%. MLG: Fixed GetErrorString and BITS macro, 8:57am  Friday, 25 December 1981
on syslisp;

% Modeled after the IDapply to avoid CONS, register reloads
% could easily be done Opencoded
% SYSLSP calls, expect W value, return appropriate register

%. syslsp procedure XJsys0(Jr1,Jr2,Jr3,Jr4,Jnum)
%. syslsp procedure XJsys1(Jr1,Jr2,Jr3,Jr4,Jnum)
%. syslsp procedure XJsys2(Jr1,Jr2,Jr3,Jr4,Jnum)
%. syslsp procedure XJsys3(Jr1,Jr2,Jr3,Jr4,Jnum)
%. syslsp procedure XJsys4(Jr1,Jr2,Jr3,Jr4,Jnum)

lap '((!*entry xjsys0 expr 5)
      (jsys (indirect (reg 5)))
      (erjmp (entry xjsyserror))
      (!*move (wconst 0) (reg 1))
      (!*exit 0))$

BothTimes put('xjsys0, 'OpenCode, '((jsys (indexed (reg 5) 0))
				    (jump 8#16 (entry xjsyserror))
				    (setzm (reg 1))));

lap '((!*entry xjsys1 expr 5)
      (jsys (indirect (reg 5)))
      (erjmp (entry xjsyserror))
      (!*exit 0))$

BothTimes put('xjsys1, 'OpenCode, '((jsys (indexed (reg 5) 0))
				    (jump 8#16 (entry xjsyserror))));

lap '((!*entry xjsys2 expr 5)
      (jsys (indirect (reg 5)))
      (erjmp (entry xjsyserror))
      (!*move (reg 2) (reg 1))
      (!*exit 0))$

BothTimes put('xjsys2, 'OpenCode, '((jsys (indexed (reg 5) 0))
				    (jump 8#16 (entry xjsyserror))
				    (move (reg 1) (reg 2))));

lap '((!*entry xjsys3 expr 5)
      (jsys (indirect (reg 5)))
      (erjmp (entry xjsyserror))
      (!*move (reg 3) (reg 1))
      (!*exit 0))$

BothTimes put('xjsys3, 'OpenCode, '((jsys (indexed (reg 5) 0))
				    (jump 8#16 (entry xjsyserror))
				    (move (reg 1) (reg 3))));

lap '((!*entry xjsys4 expr 5)
      (jsys (indirect (reg 5)))
      (erjmp (entry xjsyserror))
      (!*move (reg 4) (reg 1))
      (!*exit 0))$


BothTimes put('xjsys4, 'OpenCode, '((jsys (indexed (reg 5) 0))
				    (jump 8#16 (entry xjsyserror))
				    (move (reg 1) (reg 4))));

lap '((!*entry geterrorstring expr 1)
      (!*move (wconst -1) (reg 2))       % most recent error
      (hrli  (reg 2) 8#400000) % self process
      (!*move (wconst 0) (reg 3))        % all string
      (erstr)           % get the error string to a1 buffer
      (jfcl)
      (jfcl)
      (!*exit 0))$

syslsp procedure xjsyserror$	 %/ should load up errstr
 begin scalar s;
    s:=gtstr 200;
    geterrorstring lor(lsh(8#10700,18), s)$
    return stderror recopystringtonull s;
 end;

% --- conversions for lisp level calls

syslsp procedure str2int s; 
 sys2int strinf s;

syslsp procedure int2str i;
  mkstr int2sys i;

syslsp procedure jconv j;	%. handle untagging
 if fixp j then int2sys j
  else if stringp j 
     then lor(lsh(8#10700,18),strinf(j))  % Bug in LONG const
  else stderror list(j,'" not known in jconv");

% lisp calls. untag args, then tag result as integer
%             user has to convert result from xword, stringbase, etc

syslsp procedure jsys0(jr1,jr2,jr3,jr4,jnum);
 sys2int xjsys0(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$

syslsp procedure jsys1(jr1,jr2,jr3,jr4,jnum);
 sys2int xjsys1(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$

syslsp procedure jsys2(jr1,jr2,jr3,jr4,jnum);
 sys2int xjsys2(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$

syslsp procedure jsys3(jr1,jr2,jr3,jr4,jnum);
 sys2int xjsys3(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$

syslsp procedure jsys4(jr1,jr2,jr3,jr4,jnum);
 sys2int xjsys4(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$

syslsp procedure checknum(x,y);
 if intp x then intinf x else nonintegererror(x,y);

CommentOutCode<<
syslsp procedure insertstringsize s;
 begin scalar l,s1;			% this must not be done to a string
	l:=0; s1:=strinf(s);		% in the heap!
	while not (strbyt(s1,l)= char null) do l:=l+1;
	@s1:=mkitem(hstr,l-1);
 return s;
 end;
>>;

syslsp procedure recopystringtonull s;
 begin scalar l,s1,s2,ch;
	l:=0; s1:=strinf(s);
	while not (strbyt(s1,l)= char null) do l:=l+1;
	s2:=gtstr(l-1);
	l:=0;
	while not ((ch:=strbyt(s1,l))= char null) 
	  do <<strbyt(s2,l):= ch; l:=l+1>>;
	return mkstr s2;
  end;

% ------------ useful bit, byte and word utilities

syslsp procedure swap(x);		%. swap half words
 xword(lowhalfword x,highhalfword x);

syslsp procedure lowhalfword n;
  sys2int land(int2sys n,8#777777);

compiletime <<
syslsp smacro procedure rsh(x,y);
  lsh(x,-y);
>>;

syslsp procedure highhalfword n;
  sys2int land(rsh(int2sys n,18),8#777777);

syslsp procedure xword(x,y);   %. build word from half-words
%  sys2int lor(lsh(lowhalfword(int2sys x),18),
%                  lowhalfword int2sys y);	%/Compiler error
begin scalar Tmp;
  Tmp := lowhalfword int2sys x;
  Tmp := lsh(Tmp, 18);
  Tmp := lor(Tmp, lowhalfword int2sys y);
  return sys2int Tmp;
end;

syslsp procedure jbits l;            %. convert bit and byte fields
% l is list of bitpos or (fieldvalue . rightbitpos)
% msb is #0, lsb is #35 on dec-20
 begin scalar wd,x,fldpos,fldval;
	wd:=0;
   lb:	if not pairp l then return sys2int wd;
	x:=car l; l := cdr l;
        if pairp x then <<fldpos:=cdr x; fldval:=car x>>
         else <<fldpos:=x; fldval:=1>>;
        if not (fixp fldval and fixp fldpos) then goto lb;
	if fldpos <0 or fldpos > 35 then goto lb;
	wd := lor(wd,lsh(fldval,35-fldpos));
	goto lb;
 end;

macro procedure bits l;
 list('jbits, 'list . cdr l);


%. load jSYS Names

procedure MakeJsys(Name, Number);
    EvDefConst(Name, Number);

off syslisp;

MakeJsys( 'jsJSYS , 8#0)$
MakeJsys( 'jsLOGIN , 8#1)$
MakeJsys( 'jsCRJOB , 8#2)$
MakeJsys( 'jsLGOUT , 8#3)$
MakeJsys( 'jsCACCT , 8#4)$
MakeJsys( 'jsEFACT , 8#5)$
MakeJsys( 'jsSMON , 8#6)$
MakeJsys( 'jsTMON , 8#7)$
MakeJsys( 'jsGETAB , 8#10)$
MakeJsys( 'jsERSTR , 8#11)$
MakeJsys( 'jsGETER , 8#12)$
MakeJsys( 'jsGJINF , 8#13)$
MakeJsys( 'jsTIME , 8#14)$
MakeJsys( 'jsRUNTM , 8#15)$
MakeJsys( 'jsSYSGT , 8#16)$
MakeJsys( 'jsGNJFN , 8#17)$
MakeJsys( 'jsGTJFN , 8#20)$
MakeJsys( 'jsOPENF , 8#21)$
MakeJsys( 'jsCLOSF , 8#22)$
MakeJsys( 'jsRLJFN , 8#23)$
MakeJsys( 'jsGTSTS , 8#24)$
MakeJsys( 'jsSTSTS , 8#25)$
MakeJsys( 'jsDELF , 8#26)$
MakeJsys( 'jsSFPTR , 8#27)$
MakeJsys( 'jsJFNS , 8#30)$
MakeJsys( 'jsFFFFP , 8#31)$
MakeJsys( 'jsRDDIR , 8#32)$
MakeJsys( 'jsCPRTF , 8#33)$
MakeJsys( 'jsCLZFF , 8#34)$
MakeJsys( 'jsRNAMF , 8#35)$
MakeJsys( 'jsSIZEF , 8#36)$
MakeJsys( 'jsGACTF , 8#37)$
MakeJsys( 'jsSTDIR , 8#40)$
MakeJsys( 'jsDIRST , 8#41)$
MakeJsys( 'jsBKJFN , 8#42)$
MakeJsys( 'jsRFPTR , 8#43)$
MakeJsys( 'jsCNDIR , 8#44)$
MakeJsys( 'jsRFBSZ , 8#45)$
MakeJsys( 'jsSFBSZ , 8#46)$
MakeJsys( 'jsSWJFN , 8#47)$
MakeJsys( 'jsBIN , 8#50)$
MakeJsys( 'jsBOUT , 8#51)$
MakeJsys( 'jsSIN , 8#52)$
MakeJsys( 'jsSOUT , 8#53)$
MakeJsys( 'jsRIN , 8#54)$
MakeJsys( 'jsROUT , 8#55)$
MakeJsys( 'jsPMAP , 8#56)$
MakeJsys( 'jsRPACS , 8#57)$
MakeJsys( 'jsSPACS , 8#60)$
MakeJsys( 'jsRMAP , 8#61)$
MakeJsys( 'jsSACTF , 8#62)$
MakeJsys( 'jsGTFDB , 8#63)$
MakeJsys( 'jsCHFDB , 8#64)$
MakeJsys( 'jsDUMPI , 8#65)$
MakeJsys( 'jsDUMPO , 8#66)$
MakeJsys( 'jsDELDF , 8#67)$
MakeJsys( 'jsASND , 8#70)$
MakeJsys( 'jsRELD , 8#71)$
MakeJsys( 'jsCSYNO , 8#72)$
MakeJsys( 'jsPBIN , 8#73)$
MakeJsys( 'jsPBOUT , 8#74)$
MakeJsys( 'jsPSIN , 8#75)$
MakeJsys( 'jsPSOUT , 8#76)$
MakeJsys( 'jsMTOPR , 8#77)$
MakeJsys( 'jsCFIBF , 8#100)$
MakeJsys( 'jsCFOBF , 8#101)$
MakeJsys( 'jsSIBE , 8#102)$
MakeJsys( 'jsSOBE , 8#103)$
MakeJsys( 'jsDOBE , 8#104)$
MakeJsys( 'jsGTABS , 8#105)$
MakeJsys( 'jsSTABS , 8#106)$
MakeJsys( 'jsRFMOD , 8#107)$
MakeJsys( 'jsSFMOD , 8#110)$
MakeJsys( 'jsRFPOS , 8#111)$
MakeJsys( 'jsRFCOC , 8#112)$
MakeJsys( 'jsSFCOC , 8#113)$
MakeJsys( 'jsSTI , 8#114)$
MakeJsys( 'jsDTACH , 8#115)$
MakeJsys( 'jsATACH , 8#116)$
MakeJsys( 'jsDVCHR , 8#117)$
MakeJsys( 'jsSTDEV , 8#120)$
MakeJsys( 'jsDEVST , 8#121)$
MakeJsys( 'jsMOUNT , 8#122)$
MakeJsys( 'jsDSMNT , 8#123)$
MakeJsys( 'jsINIDR , 8#124)$
MakeJsys( 'jsSIR , 8#125)$
MakeJsys( 'jsEIR , 8#126)$
MakeJsys( 'jsSKPIR , 8#127)$
MakeJsys( 'jsDIR , 8#130)$
MakeJsys( 'jsAIC , 8#131)$
MakeJsys( 'jsIIC , 8#132)$
MakeJsys( 'jsDIC , 8#133)$
MakeJsys( 'jsRCM , 8#134)$
MakeJsys( 'jsRWM , 8#135)$
MakeJsys( 'jsDEBRK , 8#136)$
MakeJsys( 'jsATI , 8#137)$
MakeJsys( 'jsDTI , 8#140)$
MakeJsys( 'jsCIS , 8#141)$
MakeJsys( 'jsSIRCM , 8#142)$
MakeJsys( 'jsRIRCM , 8#143)$
MakeJsys( 'jsRIR , 8#144)$
MakeJsys( 'jsGDSTS , 8#145)$
MakeJsys( 'jsSDSTS , 8#146)$
MakeJsys( 'jsRESET , 8#147)$
MakeJsys( 'jsRPCAP , 8#150)$
MakeJsys( 'jsEPCAP , 8#151)$
MakeJsys( 'jsCFORK , 8#152)$
MakeJsys( 'jsKFORK , 8#153)$
MakeJsys( 'jsFFORK , 8#154)$
MakeJsys( 'jsRFORK , 8#155)$
MakeJsys( 'jsRFSTS , 8#156)$
MakeJsys( 'jsSFORK , 8#157)$
MakeJsys( 'jsSFACS , 8#160)$
MakeJsys( 'jsRFACS , 8#161)$
MakeJsys( 'jsHFORK , 8#162)$
MakeJsys( 'jsWFORK , 8#163)$
MakeJsys( 'jsGFRKH , 8#164)$
MakeJsys( 'jsRFRKH , 8#165)$
MakeJsys( 'jsGFRKS , 8#166)$
MakeJsys( 'jsDISMS , 8#167)$
MakeJsys( 'jsHALTF , 8#170)$
MakeJsys( 'jsGTRPW , 8#171)$
MakeJsys( 'jsGTRPI , 8#172)$
MakeJsys( 'jsRTIW , 8#173)$
MakeJsys( 'jsSTIW , 8#174)$
MakeJsys( 'jsSOBF , 8#175)$
MakeJsys( 'jsRWSET , 8#176)$
MakeJsys( 'jsGETNM , 8#177)$
MakeJsys( 'jsGET , 8#200)$
MakeJsys( 'jsSFRKV , 8#201)$
MakeJsys( 'jsSAVE , 8#202)$
MakeJsys( 'jsSSAVE , 8#203)$
MakeJsys( 'jsSEVEC , 8#204)$
MakeJsys( 'jsGEVEC , 8#205)$
MakeJsys( 'jsGPJFN , 8#206)$
MakeJsys( 'jsSPJFN , 8#207)$
MakeJsys( 'jsSETNM , 8#210)$
MakeJsys( 'jsFFUFP , 8#211)$
MakeJsys( 'jsDIBE , 8#212)$
MakeJsys( 'jsFDFRE , 8#213)$
MakeJsys( 'jsGDSKC , 8#214)$
MakeJsys( 'jsLITES , 8#215)$
MakeJsys( 'jsTLINK , 8#216)$
MakeJsys( 'jsSTPAR , 8#217)$
MakeJsys( 'jsODTIM , 8#220)$
MakeJsys( 'jsIDTIM , 8#221)$
MakeJsys( 'jsODCNV , 8#222)$
MakeJsys( 'jsIDCNV , 8#223)$
MakeJsys( 'jsNOUT , 8#224)$
MakeJsys( 'jsNIN , 8#225)$
MakeJsys( 'jsSTAD , 8#226)$
MakeJsys( 'jsGTAD , 8#227)$
MakeJsys( 'jsODTNC , 8#230)$
MakeJsys( 'jsIDTNC , 8#231)$
MakeJsys( 'jsFLIN , 8#232)$
MakeJsys( 'jsFLOUT , 8#233)$
MakeJsys( 'jsDFIN , 8#234)$
MakeJsys( 'jsDFOUT , 8#235)$
MakeJsys( 'jsCRDIR , 8#240)$
MakeJsys( 'jsGTDIR , 8#241)$
MakeJsys( 'jsDSKOP , 8#242)$
MakeJsys( 'jsSPRIW , 8#243)$
MakeJsys( 'jsDSKAS , 8#244)$
MakeJsys( 'jsSJPRI , 8#245)$
MakeJsys( 'jsSTO , 8#246)$
MakeJsys( 'jsBBNIIT , 8#247)$
MakeJsys( 'jsARCF , 8#247)$
MakeJsys( 'jsASNDP , 8#260)$
MakeJsys( 'jsRELDP , 8#261)$
MakeJsys( 'jsASNDC , 8#262)$
MakeJsys( 'jsRELDC , 8#263)$
MakeJsys( 'jsSTRDP , 8#264)$
MakeJsys( 'jsSTPDP , 8#265)$
MakeJsys( 'jsSTSDP , 8#266)$
MakeJsys( 'jsRDSDP , 8#267)$
MakeJsys( 'jsWATDP , 8#270)$
MakeJsys( 'jsATNVT , 8#274)$
MakeJsys( 'jsCVSKT , 8#275)$
MakeJsys( 'jsCVHST , 8#276)$
MakeJsys( 'jsFLHST , 8#277)$
MakeJsys( 'jsGCVEC , 8#300)$
MakeJsys( 'jsSCVEC , 8#301)$
MakeJsys( 'jsSTTYP , 8#302)$
MakeJsys( 'jsGTTYP , 8#303)$
MakeJsys( 'jsBPT , 8#304)$
MakeJsys( 'jsGTDAL , 8#305)$
MakeJsys( 'jsWAIT , 8#306)$
MakeJsys( 'jsHSYS , 8#307)$
MakeJsys( 'jsUSRIO , 8#310)$
MakeJsys( 'jsPEEK , 8#311)$
MakeJsys( 'jsMSFRK , 8#312)$
MakeJsys( 'jsESOUT , 8#313)$
MakeJsys( 'jsSPLFK , 8#314)$
MakeJsys( 'jsADVIS , 8#315)$
MakeJsys( 'jsJOBTM , 8#316)$
MakeJsys( 'jsDELNF , 8#317)$
MakeJsys( 'jsSWTCH , 8#320)$
MakeJsys( 'jsOPRFN , 8#326)$
MakeJsys( 'jsCGRP , 8#327)$
MakeJsys( 'jsVACCT , 8#330)$
MakeJsys( 'jsGDACC , 8#331)$
MakeJsys( 'jsATGRP , 8#332)$
MakeJsys( 'jsGACTJ , 8#333)$
MakeJsys( 'jsGPSGN , 8#334)$
MakeJsys( 'jsRSCAN , 8#500)$
MakeJsys( 'jsHPTIM , 8#501)$
MakeJsys( 'jsCRLNM , 8#502)$
MakeJsys( 'jsINLNM , 8#503)$
MakeJsys( 'jsLNMST , 8#504)$
MakeJsys( 'jsRDTXT , 8#505)$
MakeJsys( 'jsSETSN , 8#506)$
MakeJsys( 'jsGETJI , 8#507)$
MakeJsys( 'jsMSEND , 8#510)$
MakeJsys( 'jsMRECV , 8#511)$
MakeJsys( 'jsMUTIL , 8#512)$
MakeJsys( 'jsENQ , 8#513)$
MakeJsys( 'jsDEQ , 8#514)$
MakeJsys( 'jsENQC , 8#515)$
MakeJsys( 'jsSNOOP , 8#516)$
MakeJsys( 'jsSPOOL , 8#517)$
MakeJsys( 'jsALLOC , 8#520)$
MakeJsys( 'jsCHKAC , 8#521)$
MakeJsys( 'jsTIMER , 8#522)$
MakeJsys( 'jsRDTTY , 8#523)$
MakeJsys( 'jsTEXTI , 8#524)$
MakeJsys( 'jsUFPGS , 8#525)$
MakeJsys( 'jsSFPOS , 8#526)$
MakeJsys( 'jsSYERR , 8#527)$
MakeJsys( 'jsDIAG , 8#530)$
MakeJsys( 'jsSINR , 8#531)$
MakeJsys( 'jsSOUTR , 8#532)$
MakeJsys( 'jsRFTAD , 8#533)$
MakeJsys( 'jsSFTAD , 8#534)$
MakeJsys( 'jsTBDEL , 8#535)$
MakeJsys( 'jsTBADD , 8#536)$
MakeJsys( 'jsTBLUK , 8#537)$
MakeJsys( 'jsSTCMP , 8#540)$
MakeJsys( 'jsSETJB , 8#541)$
MakeJsys( 'jsGDVEC , 8#542)$
MakeJsys( 'jsSDVEC , 8#543)$
MakeJsys( 'jsCOMND , 8#544)$
MakeJsys( 'jsPRARG , 8#545)$
MakeJsys( 'jsGACCT , 8#546)$
MakeJsys( 'jsLPINI , 8#547)$
MakeJsys( 'jsGFUST , 8#550)$
MakeJsys( 'jsSFUST , 8#551)$
MakeJsys( 'jsACCES , 8#552)$
MakeJsys( 'jsRCDIR , 8#553)$
MakeJsys( 'jsRCUSR , 8#554)$
MakeJsys( 'jsSNDIM , 8#750)$
MakeJsys( 'jsRCVIM , 8#751)$
MakeJsys( 'jsASNSQ , 8#752)$
MakeJsys( 'jsRELSQ , 8#753)$
MakeJsys( 'jsTHIBR , 8#770)$
MakeJsys( 'jsTWAKE , 8#771)$
MakeJsys( 'jsMRPAC , 8#772)$
MakeJsys( 'jsSETPV , 8#773)$
MakeJsys( 'jsMTALN , 8#774)$
MakeJsys( 'jsTTMSG , 8#775)$

End$