reduce-historical/psl-1983/20-util/jsys.red

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