Google
 

Trailing-Edge - PDP-10 Archives - BB-J939E-BM - binary/blsots.mac
There are 7 other files named blsots.mac in the archive. Click here to see a list.
	UNIVERSAL $OTSDE

;
;
; Copyright (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982, 1983, 1984
; Digital Equipment Corporation,  Maynard, Massachusetts  01754
;
; This software is furnished under a license for use only on  a
; single computer system and may be copied only with the inclu-
; sion of the above copyright notice.  This  software,  or  any
; other  copies  thereof, may not be provided or otherwise made
; available to any other person except for use on  such  system
; and  to  one who agrees to these license terms.  Title to and
; ownership of the software shall at all times remain in DEC.
;
; The information in this software is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation.
;
; DEC assumes no responsibility for the use or  reliability  of
; its software on equipment which is not supplied by DEC.
;
;
;
; REVISION HISTORY:
;
;	07-Aug-79	TC	Removed .BREG.
;
;	26-Oct-81	AL	SIGNA. should always save the FP on
;				entry to make SIX12 work right.
;
;	19-Jan-82	LD	SIGNA. should save th FP only if FP exists.
;				Otherwise we were trying to save the contents
;				of -1, causing the TOPS-10 compiler to bomb.
;
;	16-Mar-82	LD	Included checks for 1-word global byte
;				pointers for CHDIF%.
;
;	22-Mar-82	LD	Fixed UNWIND to check for global byte pointers
;				when changing the stack pointer (SP).
;
;	11-Apr-82	LD	Fixed up some of the changes to CHDIF% for
;				1-word global byte pointers. The stack
;				was off since the PUSHER macro isn't
;				that smart.
;
;	29-Apr-82	LD	Added the tables for converting 1-word
;				global byte pointers to 2-word global
;				byte pointers.
;
;	18-May-82	LD	Corrected code in CHDIF% for 1-word global
;				byte pointers.
;
;	21-May-82	LD	Added the routine CHSIZ%.
;
; END V3.1 BUG FIXES
;
; BLISS V4 DEVELOPMENT
;
;	19-Nov-82	LD	Added the routine PSI36%. Added code to
;				UNWIND which checks for PS_INTERRUPT
;				linkage routines and issues a DEBRK.
;
;	22-Nov-82	LD	Moved check for PS_INTERRUPT into 
;				DO.NXTWNWIND loop.
;
;	7-Dec-82	LD	 OPDEF PIBLK. and .PSVOP for TOPS-10.
;
;	28-Mar-83	LD	Include SET%PSECT and checks for whether
;				to generate a TWOSEG or PSECTED OTS.
;
;	1-Apr-83	LD	Include the MACROS PSECTCODE, PSECTPLIT,
;				PSECTGLOBAL, PSECTOWN.
;
;	25-Apr-83	LD	Move B36%SZ out of $OTSDE.
;
;	24-Oct-83	LD	In signal_stop when we mask out the severity
;				condition we should use 7 instead of 17.
;
;	29-Dec-83	LYS	Fixed bug in CVTDF%.  When converting the
;					largest possible double word floating
;					point number to single word floating
;					point,  the result is now the largest
;					possible single word floating 
;					point number.
;
;	3-Jan-84	LYS	Added a special case to handle the most
;					negative double word floating point 
;					number in CVTDF%.  Now the result is the
;					most negative single word floating
;					point number.
;
;	25-Jan-84	LYS	Fixed bug in GLBSTK.  Because LEFPNT has
;					a zero in the left half we were ending
;					up with just LEFPNT in the SP, instead
;					of a section number,,LEFPNT
;
; END OF REVISION HISTORY
;
;
;
;				FUNCTION
; This sub-module is used to make declarations used by the rest of  the
; OTS.    It  consists  of  two  inter-related  parts.   The first part
; consists of a set of symbols and macros which are used to establish a
; linkage  type  for  the OTS in a style not too dissimilar from BLISS.
; The second part consists of a set of symbols and macros which use the
; declarations  of  the  first part to make it easy for a programmer to
; create routines consistent with any linkage.
;
;			General Usage Notes:
; Sub-modules should begin with:
;
; 	SEARCH	$OTSDE
;
; in order to access the declarations made here.
; On  this  page are some generally useful macros and initialization for
; both parts of the sub-module.

DEFINE CONCAT(NM1,NM2)
    <NM1'NM2>

DEFINE DEFCONCAT(NM1,NM2),
    <DEFINE NM1'NM2>

RADIX 10

USTYPE== 0
LNKTYPE== 1
SVTYPE== 2
TMPTYPE== 3
LCLFP== 0
DONELINKAGE== 0
DONEPRESERVE== 0
DONENOPRESERVE== 0
DONETYPE== 0


CNT== 0
REPEAT 16,
    <
    CONCAT(TP,\CNT)== USTYPE
    CNT== CNT + 1
    >
PURGE CNT

PR= 0
NPR= 0
LNK== 0

FP== -1
AP== -1

FPFLAG== 0
APFLAG== 0

RADIX 8
 
; The   following   pages  contain  declarations  relating  to  linkage
; definition.    These are of interest to anyone creating an OTS with a
; non-standard  linkage  type.    The general procedure which should be
; followed is to create a file (for purposes of discussion we will call
; it "LINKAGE.MAC") which has the following form:
;
; 	DEFINE TYPE,
; 	<
; 		. . .
; 	>
;
; Where the ellipsis  represent  one  or  more  of  the  macros  to  be
; discussed later.
;
; The following is then typed starting out at monitor command level:
;
; 	@MACRO
; 	*OTS=LINKAGE,BLSOTS
; 	*^C
;
; under TOPS-20; or:
;
; 	.R MACRO
; 	*OTS=LINKAGE,BLSOTS
; 	*^C
;
; under TOPS-10.
;
; I  have  assumed  here  that  the  OTS  source  file  (BLSOTS.MAC) is
; somewhere in the users search path.  If it  is  not,  an  appropriate
; device should be defined and specified.
;
; If  no  linkage  file is included then the OTS will be assembled with
; the BLISS-36C linkage.
;
; The first line  of  TYPE  should  be  either  PUSHJ  or  F10.   These
; correspond to the BLISS-36 linkage types of the same names.     These
; must be the first things in TYPE.  If neither is specified then PUSHJ
; is assumed.
;
; LINKAGEREGS,  PRESERVE  and  NOPRESERVE may then appear in any order.
; Each should be put on a separate line.
;
; LINKAGEREGS may take zero  to  four  arguments.     These  should  be
; enclosed in angle brackets ("<>").  The first argument represents the
; register number to be used for the SP (the stack  pointer  register).
; It  defaults  to  register  zero.  The second argument represents the
; register number for the FP (the frame pointer  register).  Defaulting
; this argument, or using a negative number, specifies that a preserved
; register is to be used as a frame pointer if one  is  needed  and  no
; frame  list  is  to  be kept.       The third argument represents the
; register number for the VR (the value return register).  It  defaults
; to  register 3.    The fourth argument represents the register number
; to be used for the AP (the argument pointer register). Note  that  it
; only  has  meaning  if  the linkage type is F10. It is ignored if the
; linkage type is PUSHJ.  If the linkage type is F10 it defaults to 14.
;
; PRESERVE  specifies  those  registers  which  are  to  be  considered
; "savable", i.e. which should be saved by any routine which uses them.
; Any register which was previously listed in a NOPRESERVE declaration,
; or  which  was or will be specified in a LINKAGEREGS declaration will
; be ignored. If a PRESERVE is not included it will default to:
;
; 	PRESERVE <0,11,12,13,14,15>
;
; if the linkage type is PUSHJ or:
;
; 	PRESERVE <>
;
; if the linkage type is F10.   Note the use of  "<"  and  ">"  in  the
; above.
;
; NOPRESERVE  specifies  those  registers  which  are  to be considered
; "temporaries", i.e.  which may  be  used  freely  but  which  may  be
; modified  by making a call.  Any register which was previously listed
; in a PRESERVE declaration, or which was or will  be  specified  in  a
; LINKAGEREGS  declaration  will  be  ignored.   If a NOPRESERVE is not
; included it will default to:
;
; 	NOPRESERVE <1,2,3,4,5,6,7,8,9,10>
;
; if linkage type is PUSHJ or:
;
; 	NOPRESERVE <1,2,3,4,5,6,7,8,9,10,11,12,13>
;
; if the linkage type is F10.   Note the use of  "<"  and  ">"  in  the
; above.
;
; All register numbers are specified in decimal radix.
;
; The  user  may  also include the declaration SET%KL.   This specifies
; that the OTS is to be  run  on  a  KL-10  processor  (for  example  a
; DECsystem-20).     If SET%KL is not specified then the code generated
; will be for a KA-10 processor and may be run on any  DECsystem-10  or
; DECsystem-20.
;
; The  TOPS20  macro  may be used to indicate that the code is destined
; for a DECsystem-20.  This will have a side effect of doing a SET%KL.
;
; Macros for three of the four pre-defined linkages  for  BLISS-36  are
; defined.    These  may  be  used  instead of PUSHJ, F10, LINKAGEREGS,
; PRESERVE and NOPRESERVE.  Available is:
;
; 	BLS36C	corresponding to BLISS36C
; 	BLSS10	corresponding to BLISS10
; 	FRTFUNC	corresponding to FORTRAN_FUNC
;
; A linkage corresponding to  FORTRAN_SUB  may  not  at  this  time  be
; defined  because of the absence of preserved registers.   An OTS with
; linkage FRTFUNC is safely callable from a BLISS routine with  linkage
; FORTRAN_SUB.
DEFINE SET%KL,
    <KLFLAG== -1>

DEFINE SET%PSECT,
    <PSECTFLG== -1>

DEFINE TOPS20,
    <
    T20FLAG== -1
    KLFLAG== -1
    >

DEFINE LNKDEFINE(REG)
    <
    CONCAT(TP,\REG)== LNKTYPE
    LNK== LNK ! <1_<REG>>
    >

DEFINE TMPDEFINE(REG)
    <
    IFE <<PR ! LNK> & <1_<REG>>>,
	<
	CONCAT(TP,\REG)== TMPTYPE
	NPR= NPR ! <1_<REG>>
	>
    >

DEFINE SVDEFINE(REG)
    <
    IFE <<NPR ! LNK> & <1_<REG>>>,
	<
	CONCAT(TP,\REG)== SVTYPE
	PR= PR ! <1_<REG>>
	>
    >

DEFINE LINKSP(REG<0>)
    <
    SP== REG
    LNKDEFINE(SP)
    >

DEFINE LINKVR(REG<3>)
    <
    VR== REG
    LNKDEFINE(VR)
    >

DEFINE LINKFP(REG<-1>)
    <
    IFNB <REG>,<FP== REG>
    IFB <REG>,<FP== -1>
    IFGE FP,
	<
	LNKDEFINE(FP)
	>
    >

DEFINE LINKAP(REG<14>)
    <
    IFN APFLAG,
	<
	IFNB <REG>,<AP== REG>
	IFB <REG>,<AP== 14>
	IFL AP,
	    <AP== 14>
	LNKDEFINE(AP)
	>
    IFE APFLAG,
	<AP== -1>
    >

DEFINE LINKAGEREGS(LRLIST),
    <
    DONELINKAGE== -1
    CNT== 0
    IRP LRLIST,
	<
	IFE CNT,
	    <LINKSP(LRLIST)>
	IFE CNT - 1,
	    <LINKFP(LRLIST)>
	IFE CNT - 2,
	    <LINKVR(LRLIST)>
	IFE CNT - 3,
	    <LINKAP(LRLIST)>
	CNT== CNT + 1
	>
    >

DEFINE PRESERVE(A)
    <
    IFE DONETYPE,
	<PSHJ>
    DONEPRESERVE== -1
    IRP A,
	<
	SVDEFINE(A)
	>
    >

DEFINE NOPRESERVE(A)
    <
    IFE DONETYPE,
	<PSHJ>
    DONENOPRESERVE== -1
    IRP A,
	<
	TMPDEFINE(A)
	>
    >

DEFINE PSHJ,
    <
    IFE DONETYPE,
	<
	DONETYPE== -1
	APFLAG== 0
	FPFLAG== 0
	DEFINE DFLTLNK,
	    <LINKAGEREGS <0,2,3>>
	DEFINE DFLTPR,
	    <PRESERVE <11,12,13,14,15,0>>
	DEFINE DFLTNPR,
	    <NOPRESERVE <1,2,3,4,5,6,7,8,9,10>>
	>
    >

DEFINE F10,
    <
    IFE DONETYPE,
	<
	DONETYPE== -1
	APFLAG== -1
	FPFLAG== 0
	DEFINE DFLTLNK,
	    <LINKAGEREGS <15,-1,0,14>>
	DEFINE DFLTPR,
	    <>
	DEFINE DFLTNPR,
	    <NOPRESERVE <1,2,3,4,5,6,7,8,9,10,11,12,13>>
	>
    >

DEFINE DFNLINKAGE,
    <
    IFE DONELINKAGE,
	<DFLTLNK>
    IFE DONEPRESERVE,
	<DFLTPR>
    IFE DONENOPRESERVE,
	<DFLTNPR>
    RCNT== 1
    TMPCNT== 0
    SVCNT== 0
    REPEAT ^D15,
	<
	IFE CONCAT(TP,\RCNT) - SVTYPE,
	    <
	    SVCNT== SVCNT + 1
	    CONCAT(SAVR,\SVCNT)== RCNT
	    >
	IFE CONCAT(TP,\RCNT) - TMPTYPE
	    <
	    TMPCNT== TMPCNT + 1
	    CONCAT(TMPR,\TMPCNT)== RCNT
	    >
	RCNT== RCNT + 1
	>
    PURGE RCNT

    PR= PR & <^-<LNK>>
    NPR= NPR & <^-<LNK>>

    IFL FP,
	<LCLFP== -1>
    IFE FPFLAG,
	<
	IFE SP,
	    <FPFLAG== -1>
	>
    IFNDEF KLFLAG,<KLFLAG== 0>
    IFNDEF T20FLAG,<T20FLAG== 0>
    IFNDEF PSECTFLG,<PSECTFLG== 0>
    IFNDEF PSECTCODE,		; If the user did not specify
        < DEFINE PSECTCODE,	; another name for the CODE
	    < .PSECT $CODE$ >>	; PSECT then use the name $CODE$.
    IFNDEF PSECTOWN,		; If the user did not specify
	< DEFINE PSECTOWN,	; another name for the OWN
	    < .PSECT $OWN$ >>	; PSECT then use the name $OWN$.
    IFNDEF PSECTPLIT,		; If the user did not specify
        < DEFINE PSECTPLIT,	; another name for the PLIT
	    < .PSECT $PLIT$ >>	; PSECT then use the name $PLIT$.
    IFNDEF PSECTGLOBAL,		; If the user did not specify
	< DEFINE PSECTGLOBAL,	; another name for the GLOBAL
	    < .PSECT $GLOBAL$ >>; PSECT then use the name $GLOBAL$.
    IFN FPFLAG,
	<
	DEFINE DYTEMP(I),<<SRCNT+LCLCNT+I>(FP)>
	>
    IFE FPFLAG,
	<
	DEFINE DYTEMP(I),<<LCLCNT-STKDPTH+I+1>(SP)>
	>

    PURGE LNK

    >
DEFINE BLS36C
    <
    PUSHJ
    LINKAGEREGS <15,13,1>
    PRESERVE <0, 6, 7, 8, 9, 10, 11, 12, 14>
    NOPRESERVE <2, 3, 4, 5>
    >

DEFINE BLSS10,
    <PUSHJ>

DEFINE FRTFUNC
    <
    F10
    PRESERVE <2,3,4,5,6,7,8,9,10,11,12,13>
    >
IFNDEF TYPE,
    <
    DEFINE TYPE,<BLS36C>
    >

RADIX 10

DEFINE PUSHJ,<PSHJ>


TYPE

DFNLINKAGE

PURGE PUSHJ

RADIX 8
; The pages which follow make declarations of use  to  writers  of  OTS
; routines.   For examples of usage style for the macros the programmer
; should examine existing routines in the OTS.
;
; The primary macro defined here is the macro ROUTINE, which sets up  a
; routine  entry.   ROUTINE takes two arguments.  The first argument to
; ROUTINE is the name of the routine.   The second argument to  ROUTINE
; is  a  list,  enclosed  in <>, of routine argument names, in the same
; order as they would be listed  a  BLISS  ROUTINE  declaration.    The
; specified  names  are  used as macro names so that the programmer may
; use these names to access the parameters whatever the linkage.
;
; The ROUTINE macro may be preceded by the  word  GLOBAL.    This  will
; cause   the   routine  to  be  declared  INTERNAL  (GLOBAL  in  BLISS
; terminology) so that it may be accesed from outside its sub-module.
;
; The ROUTINE macro may  be  followed  by  one  or  more  "declaration"
; macros.   These macros are used to declare names, consistent with the
; current linkage, of various types.  They may occur in any  order  and
; may  be  repeated  as  many times as desired.  They all take a single
; argument which is a list of names which should be enclosed  in  angle
; brackets  ("<>").  If there is a single name the brackets may be left
; off.
;
; TEMPREGS is a "declaration" macro which assigns values to  the  names
; corresponding to registers.  If there are enough available these will
; be assigned from the list of NON-PRESERVED registers for the  current
; linkage.   If there are not enough NON-PRESERVED registers available,
; they will be assigned from the list of PRESERVED  registers  for  the
; current  linkage.   If  there are not enough registers of either type
; available (how spendthrift) an error message will be typed.  Register
; 0  will  not  be  assigned  so  the  programmer  may freely use these
; registers as index registers,  etc.    These  registers  may  not  be
; depended on to retain their values "across" routine calls.
;
; SAVEREGS  is a "declaration" macro which is very similar to TEMPREGS.
; Registers will not be drawn from the list of NON-PRESERVED registers,
; however.  These  registers  may be depended on to retain their values
; "across" routine calls.
;
; The register named VR may be used as  a  TEMPREG  as  well  as  those
; declared  by  the user by use of the TEMPREG macro.  It should not be
; used as an index  register,  however,  since  it  may  correspond  to
; register 0.
;
; STKLOCALS is a "declaration" macro which causes a number of locations
; to be reserved on the stack.  The names are defined as  macros  which
; will reference these locations consistently and correctly.
;
; INITDY  is  a  macro  which is used like a "declaration" macro except
; that it takes no arguments.  It informs the system  that  the  DYTEMP
; macro described later is used in the body of the routine.
;
; After  the  "declaration"  macros  but  before  the first line of the
; routine body the macro RTNSTART should  be  inserted.   It  takes  no
; arguments.  It is NOT optional.
;
; The  symbol  NEEDFP will have a non-zero value if FP has been defined
; and set up.    LCLFP will be non-zero if NEEDFP is  non-zero  but  no
; frame thread is being maintained.
;
; The  symbol  APFLAG will be non-zero if the linkage uses an AP.    In
; this case AP will have a valid value.
;
; The symbol KLFLAG will have a non-zero value  if  the  OTS  is  being
; assembled for a KL-10 processor.
;
; The  symbol  T20FLAG  will  have a non-zero value if the OTS is being
; assembled for a DECsystem-20.  The programmer may assume that  KLFLAG
; will also be non-zero if T20FLAG is non-zero.
;
; A  routine is normally terminated by RTNEND.  This macro (which takes
; no arguments) pops the stack back to its position on entry,  restores
; any  saved  registers, and does a POPJ to return to the caller.  Code
; should terminate by branching to a label placed before this macro. It
; should be placed after all code concerned with the routine.
;
; Under  those  conditions  when  other arrangements have been made for
; terminating the routine, FAKEEND should be used  instead  of  RTNEND.
; FAKEEND  generates  no code but cleans up some bookkeeping.   FAKEEND
; should be used by experts only.
;
; So as to be able to index correctly off  the  SP,  the  system  keeps
; track  of  the  size  of  the stack.   For this reason the programmer
; should not do PUSH's POP's or ADJSP's directly.   The macros  PUSHER,
; POPPER  and  ADJSTK  are  supplied  for this purpose.   Use them.  In
; addition, ADJSTK will generate the necessary code to  simulate  ADJSP
; on  non-KL-10  systems.  Remember, that the system can only treat the
; code as a linear stream, forks and loops which do not take this  into
; account  may cause garbage to be generated.  If you consider yourself
; expert enough, the variable STKDPTH may be adjusted to  handle  forks
; and  loops with fixed number of iterations correctly.  Otherwise call
; POPPER or ADJSTK before labels.
;
; Stack locations created by  PUSHER  or  ADJSTK  are  called  dy-temps
; (dynamic-temporaries). Dy-temps may be accessed with the macro DYTEMP
; which takes a single argument.   The argument represents  the  number
; of the dy-temp.  The dy-temp created by the first PUSHER is zero, the
; dy-temp created by the second PUSHER is one, etc.
;
; Routine arguments should be generated by using PUSHER.    Before  the
; first  such  PUSHER  however, CALLSTART should be called.   CALLSTART
; takes no arguments.  The routine call itself should be  generated  by
; using the macro CALLER which takes a single argument, the name of the
; routine to be called.   After CALLER any  arguments  pushed  will  be
; popped  automatically.  The section of code between a CALLSTART and a
; CALLER is called a call-block.     Call-blocks  should  not  nest  or
; overlap.
DEFINE PUSHER(LOC)
    <
    PUSH	SP,LOC
    STKDPTH== STKDPTH + 1
    >

DEFINE POPPER(LOC)
    <
    POP	SP,LOC
    STKDPTH== STKDPTH - 1
    >

DEFINE ADJSTK(AMNT)
    <
    TMP%%%== AMNT
    IFN TMP%%%,
	<
	IFN KLFLAG,
	    <ADJSP	SP,TMP%%%>
	IFE KLFLAG,
	    <
	    IFGE TMP%%%,
		<
		ADD	SP,	
		    [<<TMP%%%>&^O777777> ! <<<TMP%%%>&^O777777>_^D18>]
		>
	    IFL TMP%%%,
		<
		SUB	SP,	
		    [<<-<TMP%%%>>&^O777777> !	
			<<<-<TMP%%%>>&^O777777>_^D18>]
		>
	    >
	STKDPTH== STKDPTH + TMP%%%
	>
    PURGE TMP%%%
    >

DEFINE CALLSTART,
    <
    IFN APFLAG,
	<
	PUSHER([0])
	MOVEI	AP,1(SP)
	>
    CLLCNT== STKDPTH
    >

DEFINE CALLER(CLDRTN),
    <
    CLLCNT== CLLCNT-STKDPTH	; Negative of the number of arguments
    IFN APFLAG,
	<
	HRLZI	VR, CLLCNT
	MOVEM	VR, -1(AP)
	>
    PUSHJ	SP,CLDRTN
    IFN APFLAG,
	<ADJSTK(<CLLCNT-1>)>
    IFE APFLAG,
	<ADJSTK(<CLLCNT>)>
    >

DEFINE SVREG(REGNAME)
    <
    PUSH	SP,REGNAME
    SRCNT== SRCNT + 1
    CONCAT(SVDR,\^D<SRCNT>)== REGNAME
    USDMSK== USDMSK ! <1 _ REGNAME>
    >

DEFINE RSTRREGS,
    <
    IFG SRCNT,
	<
	CNT== SRCNT
	REPEAT SRCNT,
	    <
	    POP	SP,CONCAT(SVDR,\^D<CNT>)
	    CNT== CNT-1
	    >
	PURGE CNT
	>
    >
DEFINE ONESV(NAME)
    <
    SKIPFLG== 0
    REPEAT ^D15,
	<
	IFE SKIPFLG,
	    <
	    SVUSED== SVUSED + 1
	    IFG SVUSED-SVCNT,
		<
		PRINTX < TOO MANY REGISTERS REQUESTED >
		HALTSVD== 1
		SKIPFLG== -1
		>
	    IFLE SVUSED-SVCNT,
		<
		IFE <USDMSK & <1 _ <CONCAT(SAVR,\^D<SVUSED>)>>>,
		    <
		    NAME== CONCAT(SAVR,\^D<SVUSED>)
		    SVREG(NAME)
		    SKIPFLG== -1
		    >
		>
	    >
	>
    PURGE SKIPFLG
    >

DEFINE ONETMP(NAME)
    <
    TSKPFLG== 0
    REPEAT ^D15,
	<
	IFE TSKPFLG,
	    <
	    IFE TMPUSED-TMPCNT
		<
		ONESV(NAME)
		IFN HALTSV,
		    <HALTTMP== -1>
		TSKPFLG== -1
		>
	    IFN TMPUSED-TMPCNT
		<
		TMPUSED== TMPUSED + 1
		IFE <USDMSK & <1 _ <CONCAT(TMPR,\^D<TMPUSED>)>>>,
		    <
		    NAME== CONCAT(TMPR,\^D<TMPUSED>)
		    USDMSK== USDMSK ! <1 _ NAME>
		    TSKPFLG== -1
		    >
		>
	    >
	>
    PURGE TSKPFLG
    >

DEFINE MAKTMPS,
    <
    CNT== 0
    REPEAT P%TCNT,
	<
	IFE HALTTMP,
	    <
	    CNT== CNT + 1
	    CONCAT(P%T,\^D<CNT>)
	    >
	>
    PURGE CNT
    >

DEFINE MAKSVS,
    <
    CNT== 0
    REPEAT P%SCNT,
	<
	IFE HALTSVD,
	    <
	    CNT== CNT + 1
	    CONCAT(P%S,\^D<CNT>)
	    >
	>
    PURGE CNT
    >

DEFINE DEFARG(DF,VAL)
    <
    IFN FPFLAG,<DF,<<VAL-1>(FP)>>
    IFE FPFLAG,<DF,<<VAL-<STKDPTH+SRCNT>>(SP)>>
    >

DEFINE DEFDSP(DF,XPS,REG)
    <DF,<<XPS>(REG)>>

DEFINE ARG%CNT,
    <-1(L%AP)>

DEFINE MAKARGS,
    <
    IFN APFLAG,
	<
	CNT== 0
	REPEAT P%PCNT,
	    <
	    DEFDSP(CONCAT(P%P,\^D<CNT+1>),\^D<CNT>,L%AP)
	    CNT== CNT + 1
	    >
	PURGE CNT
	>
    IFE APFLAG,
	<
	CNT== - P%PCNT
	REPEAT P%PCNT,
	    <
	    DEFARG(CONCAT(P%P,\^D<P%PCNT + CNT + 1>),\^D<CNT>)
	    CNT== CNT + 1
	    >
	PURGE CNT
	>
    >

DEFINE DEFSLOCAL(DF,VAL),
    <
    IFN FPFLAG,
	<
	DF,
	    <<SRCNT+VAL-1>(FP)>
	>
    IFE FPFLAG,
	<
	DF,
	    <<VAL - STKDPTH>(SP)>
	>
    >

DEFINE MAKSLCLS,
    <
    CNT== 0
    REPEAT P%LCNT,
	<
	IFNB <CONCAT(P%L,\^D<CNT>)>,
	    <
	    LCLCNT== LCLCNT + 1
	    CNT== CNT + 1
	    DEFSLOCAL(CONCAT(P%L,\^D<CNT>),\^D<LCLCNT>)
	    >
	>
    PURGE CNT
    ADJSTK(LCLCNT)
    >
DEFINE ONEADJ(NAME),
    <
    NAME== FREG%
    USDMSK== USDMSK ! <1 _ FREG%>
    IFN <PR & <1 _ FREG%>>,
	<
	SVREG(FREG%)
	>
    >

DEFINE MAKADJS,
    <
    IFN P%ACNT,
	<
	; DON'T BOTHER IF WE DON'T NEED ANY.
	MASK%== <1 _ P%ACNT> - 1		; A MASK of the reg block.
	CHKMSK== <PR ! NPR> _ <-1>	; Registers we might use.
	I%== 1		; Outer loop index.
	FREG%== -1	; First register of best block so far.
	ACNT== -1	; Count of temp regs of best block so far.

	; Outer loop: check each possible first register.
	REPEAT <^D16 - P%ACNT + 1>,
	    <
	    ; Don't bother if we already have a maximum.
	    IFN <ACNT - P%ACNT>,
		<
		; If we may use the next block of registers:
		IFE <<CHKMSK & MASK%> ^! MASK%>,
		    <
		    J%== I%		; Inner loop index.
		    TACNT== 0		; Temporary ACNT.

		    ; Inner loop.  Count of number of temps in the
		    ; block.
		    REPEAT P%ACNT,
			<
			IFN <NPR & <1 _ J%>>,
			    <
			    TACNT== TACNT + 1
			    >
			J%== J% + 1
			>

		    ; If this block is an improvement ... use it.
		    IFL <ACNT - TACNT>,
			<
			ACNT== TACNT
			FREG%== I%
			>
		    >
		I%== I% + 1
		CHKMSK== CHKMSK _ <-1>
		>
	    >

	IFL ACNT,
	    <
	    PRINTX < NO ADEQUATE BLOCKS OF REGISTERS>
	    >
	IFGE ACNT,
	    <
	    CNT== 0
	    REPEAT P%ACNT,
		<
		CNT== CNT + 1
		CONCAT(P%A,\^D<CNT>)
		FREG%== FREG% + 1
		>
	    >
	PURGE MASK%, CHKMSK, I%, FREG%, ACNT, J%, TACNT, CNT
	>
    >
DEFINE TEMPREGS(RLIST),
    <
    IRP RLIST,
	<
	P%TCNT== P%TCNT + 1
	DEFCONCAT(P%T,\^D<P%TCNT>),
	    <ONETMP(RLIST)>
	>
    >

DEFINE SAVEREGS(RLIST),
    <
    IRP RLIST,
	<
	P%SCNT== P%SCNT + 1
	DEFCONCAT(P%S,\^D<P%SCNT>),
	    <ONESV(RLIST)>
	>
    >

DEFINE STKLOCALS(LLIST),
    <
    IRP LLIST,
	<
	P%LCNT== P%LCNT + 1
	DEFCONCAT(P%L,\^D<P%LCNT>),
	    <DEFINE LLIST>
	>
    >

DEFINE ADJREGS(RLIST),
    <
    P%ACNT== 0
    IRP RLIST,
	<
	P%ACNT== P%ACNT + 1
	DEFCONCAT(P%A,\^D<P%ACNT>),
	    <ONEADJ(RLIST)>
	>
    >

DEFINE INITDY,
    <
    NEEDFP== FPFLAG
    >

DEFINE ROUTINE(NM,PRMS),
    <
    IFNDEF GLBFLG,
	<
	GLBFLG== 0
	>
    IFN GLBFLG,
	<
	NM::
	GLBFLG== 0
	>
    IFE GLBFLG,
	<
	NM:
	>

    NEEDFP== 0
    STKDPTH== 0
    HALTSVD== 0
    HALTTMP== 0
    SVUSED== 0
    TMPUSED== 0
    USDMSK== 0
    SRCNT== 0
    CLLCNT== 0
    LCLCNT== 0
    P%LCNT== 0
    P%TCNT== 0
    P%SCNT== 0
    P%PCNT== 0
    P%ACNT== 0

    IRP PRMS,
	<
	P%PCNT== P%PCNT + 1
	DEFCONCAT(P%P,\^D<P%PCNT>),
	    <DEFINE PRMS>
	>
    >

DEFINE GLOBAL,
    <
    GLBFLG== -1
    >
DEFINE RTNSTART,
    <

	;; Do we need an FP for this routine?
	IFN FPFLAG,
	    <
	    IFE APFLAG,
		<
		IFNB <PARMS>,<NEEDFP== -1>
		>
	    IFNB <SLCLS>,<NEEDFP== -1>
	    >

	IFN NEEDFP,
	    <
	    ;; If we are using a local FP, we use a TMP register if
	    ;; we can.
	    IFN LCLFP,
		<
		ONESV(FP)
		>

	    ;; If we are using a global FP, save it on the stack.
	    IFE LCLFP,
		<
		SVREG(FP)
		>

	    ;; Set the FP.
	    MOVE	FP, SP
	    >

	;; Define the requested names, saving registers as needed.
	MAKARGS
	MAKADJS

	IFN APFLAG,
	    <IFG P%PCNT,
		<
		ONESV(L%AP)
		MOVE	L%AP,AP
		>
	    >

	MAKTMPS
	MAKSVS
	MAKSLCLS
    >

DEFINE FAKEEND,
    <
	PURGE NEEDFP, STKDPTH, HALTSVD, HALTTMP, SVUSED
	PURGE TMPUSED, SRCNT, CLLCNT, LCLCNT, P%LCNT, P%TCNT,
	PURGE P%SCNT, P%PCNT
    >

DEFINE RTNEND,
    <

	;; Get rid of the stack locals plus any DYTEMPS.
	ADJSTK(<-STKDPTH>)

	;; Restore saved registers, including possibly FP.
	RSTRREGS

	POPJ	SP, 0

	;; Get rid of local symbol names.
	FAKEEND
    >

LIT
PRGEND
;  CONDITION HANDLING

TITLE $OTSCH: CONDITION HANDLING

SEARCH	$OTSDE

IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

; This sub-module handles the condition handling mechanism.

ENTRY UNWND., SIGNA., SIGST., SIGND.

SUBTTL UNWND.


EXTERNAL	EFPNT.


GLOBAL ROUTINE UNWND.

RTNSTART
    SETOM	0, UWFLAG
RTNEND
SUBTTL SIGNAL

GLOBAL ROUTINE SIGNA.,<ARGUMENT>
    TEMPREGS	<TMP>
    SAVEREGS	<LEFPNT>
    INITDY

IFN FP+1,		; Save the FP if one exists
<
LCLFP==0
NEEDFP==-1
>

RTNSTART
    ; Set up an enable frame.
    PUSHER	EFPNT.
    PUSHER	[[EXP	SIGCH,0]]

    ; Save the enable frame pointer then establish this enable frame.
    PUSHER	EFPNT.
    MOVEI	TMP,DYTEMP<0>
    MOVEM	TMP,EFPNT.

    ; Save the UNWIND flag and clear it.
    PUSHER	UWFLAG
    SETZM	UWFLAG

    ; Set up the mechanism vector.
    PUSHER	[1]
    PUSHER	VR

    ; Get the address of the signal vector.
    IFN APFLAG,
	<
	; If there is an AP:

	; PUSH the argument count.
	PUSHER	[-3,,0]

	; ARGUMENT points to the SIGNAL vector.
	MOVEI	TMP, ARGUMENT
	>
    IFE APFLAG,
	; If there is no AP: ARGUMENT is after the last entry in
	; the SIGNAL vector and contains the negative of the length
	; of the SIGNAL vector including the "vector length word".
	<
	MOVE	TMP, ARGUMENT
	ADDI	TMP, ARGUMENT
	>
    PUSHER	TMP

    ; Second argument is the address of the mechanism vector.
    MOVEI	TMP, DYTEMP<4>
    PUSHER	TMP

    ; Loop back here to do a resignal:
DO.RESIGNAL:

    ; Make a local EF pointer
    MOVE	LEFPNT., DYTEMP<0>
    SKIPN	LEFPNT.
    MOVEI	LEFPNT., DFLTEF

    ; Reset the EF thread to point to the previous enable frame.
    MOVE	TMP, (LEFPNT.)
    MOVEM	TMP, DYTEMP<0>

    ; Call enable handler with the EF as the argument
    PUSHER	LEFPNT.

    ; If we are using it, set the AP here.
    IFN APFLAG,
	<
	MOVEI	AP,DYTEMP<7>
	>

    ; Calculate the address of the condition handler caller, and
    ; call it.
    MOVE	TMP, 1(LEFPNT.)
    MOVE	TMP, (TMP)
    PUSHJ	SP,(TMP)
    POPPER	TMP		; TMP is a bit bucket here.

    ; Was UNWIND requested?
    SKIPN	UWFLAG
    JRST	DO.NOUNWIND

    ; Yes -- do it.

    ; Get rid of the remaining arguments, the argument count if there
    ; is one and the mechanism vector.  But first save the stack depth.

    SAVSTKDPTH== STKDPTH

    IFN APFLAG,
	<
	ADJSTK	-5
	>
    IFE APFLAG,
	<
	ADJSTK	-4
	>

    ; Restore the unwind flag and the enable frame pointer.
    POPPER	UWFLAG
    POPPER	EFPNT.

    CALLSTART
	PUSHER	LEFPNT.
    CALLER	UNWIND

    ; We never return from here.  STKDPTH is adjusted to keep the macros
    ; happy.
    STKDPTH== SAVSTKDPTH

DO.NOUNWIND:

    ; UNWIND wasn't requested.  Was resignaling?
    TRNN	VR, 1
    JRST	DO.RESIGNAL

    ; No.  Continue (i.e. return from SIGNAL)

    ; Eliminate the remaining arguments and the argument count if there
    ; is one.

    IFN APFLAG,
	<
	ADJSTK	-3
	>
    IFE APFLAG,
	<
	ADJSTK	-2
	>

    ; Set the return value as directed by the condition handler(s)
    POPPER	VR
    POPPER	TMP		; TMP is acting as a bit bucket.

    POPPER	UWFLAG
    POPPER	EFPNT.
RTNEND
SUBTTL SIGCH	The condition handler for SIGNA.

ROUTINE SIGCH,<SV,MV,EF>
    TEMPREGS	<EFTMP,LEFPNT>

RTNSTART
    CNDVAL== EFTMP

    ; Get the condition value, mask out irrelevant portions.
    MOVE	CNDVAL,SV
    MOVE	CNDVAL,1(CNDVAL)
    AND		CNDVAL,[037777,,777760]

    ; Return with resignal if this is not an unwind.
    CAME	CNDVAL,[SS$UNW]
    JRST	SIGCHFIN

    ; If this is an unwind the enable frame pointer
    ; should be reset to point to immediate preceding
    ; enable frame rather than the preceding "active" enable frame.
    MOVE	EFTMP, EF
    MOVE	LEFPNT., 2(EFTMP)
    MOVEM	LEFPNT., EFPNT.

    ; Continue following the thread.
SIGCHFIN:
    
    SETZ	VR,
RTNEND
SUBTTL SIGNAL_STOP

GLOBAL ROUTINE SIGST., <ARGUMENT>
    TEMPREGS	<TMP,PNT>
    SAVEREGS	<VALUE>

IFN FP+1,
	<LCLFP==0
	 NEEDFP==-1
	>
RTNSTART

    IFN APFLAG,
	<
	HLLZ	TMP,-1(AP)
	PUSH	SP,TMP
	HRR	TMP,(AP)
	>
    IFE APFLAG,
	<
	HRRI	TMP,ARGUMENT
	ADD	TMP,ARGUMENT
	HRL	TMP,ARGUMENT
	SUB	TMP,[1,,0]
	>

    MOVE	PNT, SP		; Compute where condition value will be
    SUB		PNT, ARGUMENT	;  after we make copy of the arglist

SSTPLOOP:			; This is all necessary in case there is an
    PUSH	SP,(TMP)	;  AP and the incoming argument-list is in
    AOBJN	TMP,SSTPLOOP	;  read-only memory

    ;+
    ; Arg-list all copied
    ;-

    MOVE	VALUE,(PNT)	; The signalled condition-value
    ANDCMI	VALUE,7	; Strip the severity
    ORI		VALUE,4		;  and make it a FATAL one
    MOVEM	VALUE,(PNT)	; Plunk it back in the arg-list

    IFN APFLAG,
	<
	MOVEI	AP,-1(PNT)
	>

    PUSHJ	SP,SIGNA.

    ; Shouldn't return to here ... ever.

    CALLSTART
	PUSHER	[0,,SSPMSG]
    CALLER	STROUT

    CALLSTART
	PUSHER	VALUE
    CALLER	OUTOCT

    ; Return to the monitor.
    CALLSTART
    CALLER	MONRET

FAKEEND

SSPMSG:	ASCIZ/%BLSOTS	Attempt to return from SIGNAL_STOP
			Condition value = /
SUBTTL UNWIND

IFN T20FLAG,
    <
    SEARCH MONSYM		; Recognize JSYS calls
    >

IFE T20FLAG
    <
    OPDEF PIBLK. [CALLI 212]
    OPDEF XMOVEI [SETMI]
    .PSVOP== 1
    >

ROUTINE UNWIND,<ESTABLISHER>
    TEMPREGS	<TMP,XIT>
    SAVEREGS	LEFPNT.
    INITDY


RTNSTART
    ; Save the UNWIND flag and clear it.
    PUSHER	UWFLAG
    SETZM	UWFLAG

    ; Set up the signal vector.
    PUSHER	[1]
    PUSHER	[SS$UNW]

    ; Set up the mechanism vector.
    PUSHER	[1]
    PUSHER	VR

    ; PUSH the argument count if one is needed
    IFN APFLAG,
	<
	PUSHER	[-3,,0]
	>

    ; PUSH the address of the signal vector.
    MOVEI	TMP, DYTEMP<1>
    PUSHER	TMP

    ; PUSH the address of the mechanism vector.
    MOVEI	TMP, DYTEMP<3>
    PUSHER	TMP

    ; Loop back here for each establisher unwound.
DO.NXTUNWIND:

    ; Make a local EF pointer
    MOVE	LEFPNT., EFPNT.

    ; Reset the EF pointer to point to the previous entry frame.
    MOVE	TMP, (LEFPNT.)
    MOVEM	TMP, EFPNT.

    ; Call the enable handler with the EF as the argument.
    PUSHER	LEFPNT.

    ; If we are using it, set the AP.
    IFN APFLAG,
	<
	MOVEI	AP,DYTEMP<6>
	>

    ; Find the address of the condition handler caller and call it.
    MOVE	TMP, 1(LEFPNT.)
    MOVE	TMP, (TMP)
    PUSHJ	SP,(TMP)
    POPPER	TMP		; TMP is used as a bit bucket.

    ; Find the address of the exit code (DEBRK flag in left half).
    MOVE	XIT, 1(LEFPNT.)
    MOVE	XIT, 1(XIT)

    ; Check if we are unwinding thru a PS_INTERRUPT
    ; linkage-type routine.
    SKIPL	XIT		; Is this a PS_INTERRUPT linkage?
      JRST	CHKEST		; No
IFN T20FLAG,			; Yes, (TOPS-20 implementation)
    <
    PUSHER	XIT		; Save registers.
    PUSHER 	1
    PUSHER 	2
    PUSHER  	3
    MOVEI	1, .FHSLF	; Get active channels
    RWM%			;  of current process
      ERJMP	KPUNWD		; Error - ignore DEBRK
    JFFO	2, ACTIVE	; Find active channel #
      JRST 	KPUNWD		; No active channels
ACTIVE:
    CAILE	3, 3		; Bit 1,2,3 for priority levels
      JRST	KPUNWD		; Error - Ignore DEBRK
    MOVEI	1, .FHSLF	; Get pointer to PSI
    RIR				; Get channel and priority level table address
      ERJMP	XTEND		; Must be in extended addressing mode
    JUMPE	2, XTEND	; SIR wasn't isuued..check for extended addr.
    HLRZ	2, 2		; Get priority level table address only
    ADDI	2, -1(3)	; Form address of saved PC
    XMOVEI	1, KPUNWD	; Make DEBRK continue inside
    MOVEM	1, @(2)		;  unwind OTS code
    DEBRK%			; Dismiss interrupt and enable
      ERJMP	KPUNWD		; Error - fake a return

; Here if we're in extended addressing mode and we're unwinding
; thru a PS_INTERRUPT linkage-type routine.
XTEND:
    ADJSP	SP, 3		; Space for returned
    MOVEI	2, -2(SP)	;  argblock with PSI
    XRIR%		  	;  data-bases
      ERJMP	KPUNW1		; Error - ignore DEBRK
    SOS		3		; Adjust for offset into priority level table
    ADD		3, -1(SP)	; Form addr of saved PC
    MOVE	3, (3)	; Get the PC block for this priority
    XMOVEI	1, KPUNW1	; Make DEBRK continue inside
    MOVEM	1, 1(3)		;  unwind OTS code
    DEBRK%			; Dismiss interrupt and enable
      ERJMP	KPUNW1		; Error - Fake a return

KPUNW1:
    ADJSP	SP, -3		; Remove XRIR arg-block

; Restore the saved registers.
KPUNWD:
    POPPER	3
    POPPER	2
    POPPER	1
    POPPER	XIT
    >
IFE T20FLAG,			; TOPS-10 code for dismissing interrupt
    <				;   (must be 7.02 or later)
    PIBLK.	TMP,		; Get the current interrupt block
      JRST	CHKEST		; Error - ignore DEBRK.
    PUSHER 	XIT		; Need another register
    XMOVEI	XIT, CHKEST	; Make DEBRK. continue inside
    MOVEM	XIT, .PSVOP(TMP);  unwind OTS code
    POPPER	XIT		; Restore the register
    DEBRK.			; Return with PSI activated
      JRSTF	@.PSVOP(TMP)	; ERROR! Fake a return

; If we fall thru to here, then the DEBRK. is really
; messed up. Restore return address and act as if
; nothing happened.
    JRSTF	@.PSVOP(TMP)	; Return to caller as if
    >				; nothing happened

; Loop unless this is the establisher which requested the unwind.
CHKEST:
    CAME	LEFPNT., ESTABLISHER
    JRST	DO.NXTUNWIND

    ; Set up the return value.
    MOVE	VR, DYTEMP<4>

; Back the SP to point to first word of the enable frame.
    HLLZ	TMP, SP		; Check if this a local or global stack pointer.
    JUMPG	TMP, GLBSTK

; Here if local stack pointer.
    HRRZ	TMP, SP
    SUB		TMP, LEFPNT.
    HRL		TMP, TMP
    JRST	LEAVE

; Here if global stack pointer.
; A Global stack pointer contains a section number in
; the left half. Therefore we do not want to destroy this.
; However LEFPNT has a zero in the left half,
; so we need to zero the left half of the SP
; when loading it into TMP so that the SUB SP,TMP
; at LEAVE won't cancel out the left half
GLBSTK:
    HRRZ	TMP, SP
    SUB		TMP, LEFPNT.

LEAVE:
    SUB 	SP, TMP
; Exit from the establisher.
    JRST	(XIT)
SIGND.::
FAKEEND
SUBTTL DFLTCH	The default condition handler.

ROUTINE DFLTCH,<SV,MV,EV>

RTNSTART
    CALLSTART
	PUSHER	[0,,DCHMSG]
    CALLER	STROUT

    MOVE	TMP,SV
    MOVE	TMP,1(TMP)
    CALLSTART
	PUSHER	TMP
    CALLER	OUTOCT
    CALLSTART
    CALLER	MONRET

FAKEEND

DCHMSG: ASCIZ/%BLSOTS	No condition handler established for signal.
			Condition Value = /

DFLTEF:	EXP	0,[EXP	DFLTCH, DFLTCH]
SUBTTL MONRET ROUTINE  return to the monitor...and stay there.

IFN T20FLAG,
    <
    SEARCH MONSYM
    >

IFE T20FLAG,
    <
    ROUTINE MONRET

    RTNSTART

	EXIT

    RTNEND
    >

IFN T20FLAG,
    <
    ROUTINE MONRET

    RTNSTART

    MR.START:
	HALTF

	; Don't let it continue.

	HRROI	1,[ASCIZ/Can't continue/]
	PSOUT
	HRROI	1, CRLF
	PSOUT

	JRST	MR.START
    RTNEND
    >
SUBTTL STROUT routine

IFE T20FLAG,
    <
    ROUTINE STROUT, <ASZPNT>

    RTNSTART
	TTCALL	3, @ASZPNT
    RTNEND
    >

IFN T20FLAG,
    <
    ROUTINE STROUT,<ASZPNT>

    RTNSTART
	AC1== 1
	SSP== 2
	PNTSV== ^D35 - ^L<<PR ! NPR> & ^O17774>

	PUSHER	PNTSV
	MOVE	PNTSV,ASZPNT

	PUSHER	AC1
	PUSHER	SSP
	MOVE	SSP,SP

	HRRO	AC1,PNTSV
	PSOUT

	MOVE	SP,SSP
	POPPER	SSP
	POPPER	AC1
	POPPER	PNTSV
    RTNEND
    >
SUBTTL	OUTOCT ROUTINE

IFE T20FLAG,
    <

    ROUTINE	OUTOCT, <VALU>
	TEMPREGS	<CFLAG,CNTR,ARG,TMP>

    RTNSTART
	SETZ	CFLAG,
	MOVE	ARG,VALU

    OO.OLOOP:
	HRREI	CNTR,-6

    OO.ILOOP:
	ROT	ARG,3
	MOVE	TMP,ARG
	ANDI	TMP,7
	ADDI	TMP,"0"
	TTCALL	1,TMP
	AOJL	CNTR,OO.ILOOP

	JUMPN	CFLAG,OO.FIN

	TTCALL	3,[ASCIZ/,,/]
	SETO	CFLAG,
	JRST	OO.OLOOP

    OO.FIN:

    RTNEND
    >

IFN T20FLAG,
    <
    ROUTINE	OUTOCT, <VALU>

    RTNSTART

    ; We can't really make use of the macros here because of the
    ; demands that JSYS makes on register usage.  This should probably
    ; eventually be fixed up with an appropriate set of JSYSROUTINE
    ; macros.  For now: this cluge.

	AC1== 1
	AC2== 2
	AC3== 3
	SSP== 4
	ARG== ^D35 - ^L<<PR ! NPR> & ^O17760>

	PUSHER	ARG		; Save register 5
	MOVE	ARG,VALU

	; Save the other registers
	PUSHER	AC1
	PUSHER	AC2
	PUSHER	AC3
	PUSHER	SSP

	; Save the SP
	MOVE	SSP,SP

	MOVEI	AC1,.PRIOU
	MOVE	AC3,[NO%MAG ! NO%LFL ! NO%ZRO ! <^D6B17> ! ^D8]
	HLRZ	AC2,ARG
	NOUT
	    ERJMP	OO.FIN		;Exit on error.
	HRROI	AC1,[ASCIZ/,,/]
	PSOUT
	MOVEI	AC1,.PRIOU
	HRRZ	AC2,ARG
	NOUT
	    ERJMP	OO.FIN
    OO.FIN:
	MOVE	SP,SSP
	POPPER	SSP
	POPPER	AC3
	POPPER	AC2
	POPPER	AC1
	POPPER	ARG
    RTNEND
    >
SS$UNW=:	017777,,377760
CRLF:		BYTE (7) 15,12,0


IFE PSECTFLG
    <
     RELOC 0		; Low Segment
    >

IFN PSECTFLG
    <
     PSECTOWN
    >

UWFLAG:		BLOCK 1


LIT
PRGEND
TITLE EFPNT.: INITIAL
	SEARCH $OTSDE

IFE PSECTFLG
    <
     TWOSEG
     RELOC 0
    >

IFN PSECTFLG
    <
     PSECTGLOBAL
    >

; This sub-module contains only the variable EFPNT.
; This variable is always initialized by the main module and so
; it will always be loaded.

ENTRY EFPNT.

EFPNT.::	Z

LIT
PRGEND
TITLE B36%SZ
	SEARCH $OTSDE

IFE PSECTFLG
    <
     TWOSEG
     RELOC 0
    >

IFN PSECTFLG
    <
     PSECTGLOBAL
    >

ENTRY B36%SZ			; This is so /Search will see this symbol
; B36%SZ is a table used in the process of converting
; a 1-word global byte pointer to a 2-word global
; byte pointer.
;
; It is indexed by size and contains the address of
; another table (B36%6,7,8,9,18 and DEFLT). Given
; the position and size of the 2-word pointer, these
; tables contain the corresponding 'P' field for
; the 1-word global byte pointer.

B36%6:					; 6-bit character size
	BYTE(6)45,46,47,50,51,52,53
DEFLT:					; Default table 
B36%7:					; 7-bit character size
	BYTE(7)61,62,63,64,65,66
B36%8:					; 8-bit character size
	BYTE(8)54,55,56,57,60
B36%9:					; 9-bit character size
	BYTE(9)67,70,71,72,73
B36%18:				; 18-bit character size
	BYTE(18)74,75,76

B36%SZ::
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	B36%6
	B36%7
	B36%8
	B36%9
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	B36%18
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT
	DEFLT

    LIT
    PRGEND
	TITLE	PSI36%
	ENTRY	PSI36%
SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

; Phony routine to make SIX12 happy. These will never
;  be executed, but they look "good" to SIX12 when
;  it rummages thru the stack for arg. counts, etc.
;  (Used with PS_INTERRUPT linkage routines)

    PUSHJ	SP, PSI36%	; These two instructions
PSI36%::
    POPJ	SP,		;  are never executed!

    LIT
    PRGEND
	TITLE	CHPLU%
SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHPLU%')(PTR, I)
;
; FUNCTION:
;    Implements the BLISS character function CH$PLUS.
;
; INPUTS:
;    PTR --	A byte pointer.
;    I --	A character count (index).
;
; OUTPUTS:
;    VALUE --	A byte pointer which references the byte (character)
;	"I" characters after the character referenced by PTR.
;
; OTHER ROUTINES USED:
;    CHCNP%
;    CHCBP%
;-

    ENTRY CHPLU%

GLOBAL ROUTINE CHPLU%,<PTR,I>

TEMPREGS	<CHSIZE>		; Character size.

RTNSTART
    CALLSTART
	PUSHER	PTR			; Convert pointer to absolute
    CALLER	CHCNP%##		;    character position.

    ADD		VR, I
    LDB		CHSIZE,[POINT	6,PTR,11]

    CALLSTART
	PUSHER	CHSIZE
	PUSHER	VR			; Convert absolute character
    CALLER	CHCBP%##		;    to pointer.
RTNEND

	LIT
	PRGEND
	TITLE	CHPTR%
	ENTRY	CHPTR%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHPTR%')(ADDR, I, CHSIZE)
;
; FUNCTION:
;    Implements CH$PTR.
;
; INPUTS:
;    ADDR --	The base address.
;    I --	The number of characters after the first character of
;		the base address.
;    CHSIZE --	The number of bits-per-chracter.
;
; OUTPUT:
;    VALUE --	A character pointer for the specified character.
;
; OTHER ROUTINES USED:
;    CHCNO%
;    CHCBP%
;-


GLOBAL ROUTINE CHPTR%, <ADDR,I,CHSIZE>

RTNSTART
    CALLSTART
	PUSHER	ADDR
	PUSHER	CHSIZE
    CALLER	CHCNO%##
    ADD		VR,I
    CALLSTART
	PUSHER	CHSIZE
	PUSHER	VR
    CALLER	CHCBP%##
RTNEND

	LIT
	PRGEND
	TITLE	CHDIF%
	ENTRY	CHDIF%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHDIF%')(PTR1,PTR2)
;
; FUNCTION:
;    Implements the CH$DIFF character function.
;
; INPUTS:
;    PTR1 --	Character pointer to the first character.
;    PTR2 --	Character pointer to the second character.
;
; OUTPUTS:
;    VALUE --	The number of characters between the first and second
;		characters.
;
; OTHER ROUTINES USED:
;    CHCNP% -- If only local byte pointers are passed.
;    CHCNE% -- If a global byte pointer is passed.
;-


GLOBAL ROUTINE CHDIF%, <PTR1, PTR2>

TEMPREGS	<TMP>
INITDY

RTNSTART

    ; Pick up 'P' from PTR2.
    LDB		VR, [POINT 6,PTR2,5]
    SUBI	VR, ^D36
    JUMPG	VR, GLBPTR	; Check if we're dealing with one-word global byte pointers.

    ; Pick up 'P' from PTR1.
    LDB		VR, [POINT 6,PTR1,5]
    SUBI	VR, ^D36
    JUMPG	VR, GLBPTR	; Check if we're dealing with one-word global byte pointers.

; Here when dealing with only local byte pointers.
    CALLSTART
	PUSHER	PTR2
    CALLER	CHCNP%##
    PUSHER	VR		; Save result.

    CALLSTART
	PUSHER	PTR1
    CALLER	CHCNP%##
    POPPER	TMP		; Get back PTR2 result so we won't mess up the stack.
    JRST	RETURN

; Here when dealing with global byte pointers.
GLBPTR:
    CALLSTART
	PUSHER	-<STKDPTH+SRCNT>(SP)	; Push the return PC to get section #.
	PUSHER	PTR2
    CALLER	CHCNE%##
    PUSHER	VR		; Save result.

    CALLSTART
	PUSHER	-<STKDPTH+SRCNT>(SP)	; Push the return PC to get section #.
	PUSHER	PTR1
    CALLER	CHCNE%##
    POPPER	TMP		; Get back PTR2 result so we won't mess up the stack.

RETURN:
    SUB		VR, TMP
RTNEND

	PRGEND
	TITLE	CHCNP%
	ENTRY CHCNP%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHCNP%')(PTR)
;
; FUNCTION:
;     Converts a character pointer to an absolute character number.
;
; INPUTS:
;    PTR --	The character pointer.
;
; OUTPUTS:
;    VALUE --	The absolute character number.
;-

GLOBAL ROUTINE CHCNP%, <PTR>

    TEMPREGS	<CHSIZE>
    ADJREGS	<CPW,DUMMY>
    CHRS==	CPW

RTNSTART
    LDB		CHSIZE, [POINT 6,PTR,11]

    ; CPW = [36/CHSIZE]
    MOVEI	CPW, ^D36
    IDIV	CPW, CHSIZE

    ; VR = (ADDRESS*CPW)-[(POS-36)/CHSIZE]
    HRRZ	VR, PTR
    IMUL	VR, CPW
    LDB		CHRS, [POINT 6,PTR,5]
    SUBI	CHRS, ^D36
    IDIV	CHRS, CHSIZE
    SUB		VR, CHRS
    SOJ		VR,
RTNEND

	LIT
	PRGEND
	TITLE	CHCNE%
	ENTRY CHCNE%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHCNE%')(PC,PTR)
;
; FUNCTION:
;     Converts a character pointer to an absolute character number.
;	It is called by 'CHDIF%' when a 1-word global byte pointer is
;	passed as an argument to CH$DIFF.  It is similar to CHCNP% 
;	except that: (1) If a local byte ptr. is passed then the
;	current section number is also used in calculating the character
;	number. (2) If a global byte pointer is passed then we must
;	translate "P" into the correct size and position.
;
; INPUTS:
;    PC --	The return PC of CHDIF% (used to get section #)
;    PTR --	The character pointer.
;
; OUTPUTS:
;    VALUE --	The absolute character number.
;-

GLOBAL ROUTINE CHCNE%, <PC, PTR>

    TEMPREGS	<CHSIZE>
    ADJREGS	<CPW,DUMMY>
    CHRS==	CPW

RTNSTART
    LDB	CHSIZE, [POINT 6,PTR,5]		; Check if 1-word global byte pointer.
    SUBI	CHSIZE, ^D37
    JUMPGE	CHSIZE, GLBPTR

; Here when Local byte pointer
    LDB		CHSIZE, [POINT 6,PTR,11]

    ; CPW = [36/CHSIZE]
    MOVEI	CPW, ^D36
    IDIV	CPW, CHSIZE

    ; VR = (ADDRESS*CPW)-[(POS-36)/CHSIZE]
    HLLI	VR, PC			; Get the section number.
    HRR		VR, PTR
    IMUL	VR, CPW
    LDB		CHRS, [POINT 6,PTR,5]
    SUBI	CHRS, ^D36
    IDIV	CHRS, CHSIZE
    JRST	COMMON

; Here when 1-word global byte pointer.
GLBPTR:
    HLRZ	CPW, GLBTAB(CHSIZE)	; Get the number of characters per word.

    ;VR = (ADDRESS*CPW)-[(POS-36)/CHSIZE]
    SETZ	VR,
    LDB		VR, [POINT 30,PTR,35]	; Get the address.
    IMUL	VR, CPW
    HRRE	CHRS, GLBTAB(CHSIZE)	; Get [(POS-36)/CHSIZE].
    
COMMON:
    SUB		VR, CHRS
    SOJ		VR,
RTNEND

;
; GLBTAB - Table used for converting 1-word global byte pointers
;	   to an absolute character number.
;	   It is indexed by the character size.
;	   The left half of the each word represents the
;	   number of characters per word and the right
;	   half is: POSITION-36/CHARACTER-SIZE.
;
GLBTAB:
    EXP		<^D36/6,,0>
    EXP		<^D36/6,,-1>
    EXP		<^D36/6,,-2>
    EXP		<^D36/6,,-3>
    EXP		<^D36/6,,-4>
    EXP		<^D36/6,,-5>
    EXP		<^D36/6,,-6>

    EXP		<^D36/^D8,,0>
    EXP		<^D36/^D8,,-1>
    EXP		<^D36/^D8,,-2>
    EXP		<^D36/^D8,,-3>
    EXP		<^D36/^D8,,-4>

    EXP		<^D36/7,,0>
    EXP		<^D36/7,,-1>
    EXP		<^D36/7,,-2>
    EXP		<^D36/7,,-3>
    EXP		<^D36/7,,-4>
    EXP		<^D36/7,,-5>

    EXP		<^D36/^D9,,0>
    EXP		<^D36/^D9,,-1>
    EXP		<^D36/^D9,,-2>
    EXP		<^D36/^D9,,-3>
    EXP		<^D36/^D9,,-4>

    EXP		<^D36/^D18,,0>
    EXP		<^D36/^D18,,-1>
    EXP		<^D36/^D18,,-2>

	LIT
	PRGEND
	TITLE	CHCNO%
	ENTRY CHCNO%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHCNO%')(ADDR, CHSIZE)
;
; FUNCTION:
;     Converts a character description to an absolute character number.
;     It is called by 'CHPTR%'.  It is similar to CHCNP% except that
;     (1) It gets the address and size from its parameters. (2) It
;     assumes that the position is 36 (i.e. before the leftmost bit).
;
; INPUTS:
;    ADDR --	The base address for the character.
;    CHSIZE --	The number of bits-per-character.
;
; OUTPUTS:
;    VALUE --	The absolute character number.
;-

GLOBAL ROUTINE CHCNO%, <ADDR, CHSIZE>

    ADJREGS	<CPW,DUMMY>

RTNSTART

    ; VR = (ADDRESS*CPW) - 1
    HRRZ	VR, ADDR
    MOVEI	CPW, ^D36
    IDIV	CPW, CHSIZE
    IMUL	VR, CPW
    SOJ		VR,
RTNEND

	LIT
	PRGEND
	TITLE	CHCBP%
	ENTRY	CHCBP%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHCBP%')(CHSIZE, CHRNUM)
;
; FUNCTION:
;    Converts an absolute character number to a character pointer.
;
; INPUTS:
;    CHSIZE --	The number of bits-per-character
;    CHRNUM --	The absolute character number.
;
; OUTPUTS:
;    VALUE --	A character pointer to the specified character.
;-

GLOBAL ROUTINE CHCBP%, <CHSIZE, CHRNUM>

    TEMPREGS	<TMP>
    ADJREGS	<DR1,DR2>
    CPW==	DR1
    INITDY

RTNSTART
    SETZ	VR,

    ; SIZE = CHSIZE
    MOVE	TMP, CHSIZE
    DPB		TMP, [POINT 6,VR,11]

    ; CPW = [36/CHSIZE]
    MOVEI	CPW, ^D36
    IDIV	CPW, TMP
    PUSHER	CPW

    ; DR1 = [CHRNUM/CHSIZE]
    ; DR2 = CHRNUM MOD CHSIZE
    MOVE	DR1, CHRNUM
    IDIV	DR1, DYTEMP<0>

;   ADDRESS = DR1
    HRR		VR, DR1

    ; POSITION = 36 - (DR2 + 1)*CHSIZE
    AOJ		DR2,
    IMUL	TMP, DR2
    MOVEI	DR2, ^D36
    SUB		DR2, TMP
    DPB		DR2, [POINT 6,VR,5]
RTNEND

	LIT
	PRGEND
	TITLE	CHFCH%
	ENTRY	CHFCH%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHFCH%')(N, PTR, CHAR)
;
; FUNCTION:
;    Implements CH$FIND_CH.
;
; INPUTS:
;    N --	The number of characters in the string.
;    PTR --	A character pointer to the first character in the
;		string.
;    CHAR --	The character to be found.
;
; OUTPUTS:
;    VALUE --	A character pointer to the first occurence of
;		the character "CHAR" after the character pointed to
;		by "PTR".  If there are no occurrences of "CHAR"
;		in the first "N" characters following "PTR" return
;		the failure character pointer (0).
;-

GLOBAL ROUTINE CHFCH%, <N, PTR, CHAR>

    TEMPREGS	<LNG, TPTR, TSTCHR>

RTNSTART

    ; Load "N" into the length register.  Take the faiure return
    ; if "N" is less-than-or-equal-to zero.
    SKIPG	LNG, N
    JRST	FAIL

    MOVE	TPTR, PTR
LOOP:
    MOVE	VR, TPTR
    ILDB	TSTCHR, TPTR
    CAMN	TSTCHR, CHAR
    JRST	RETURN
    SOJG	LNG, LOOP
FAIL:
    SETZ	VR,
RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHFNC%
	ENTRY	CHFNC%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHFNC%')(N, PTR, CHAR)
;
; FUNCTION:
;    Implements CH$FIND_NOT_CH.
;
; INPUTS:
;    N --	The number of characters in the string.
;    PTR --	A character pointer to the first character in the
;		string.
;    CHAR --	The character to be "skipped over".
;
; OUTPUTS:
;    VALUE --	A character pointer to the first occurence of a
;		character other than "CHAR" after the character pointed
;		to by "PTR".  If the first "N" characters after "PTR"
;		are equal to "CHAR" returns the failure character
;		pointer (0).
;-

GLOBAL ROUTINE CHFNC%, <N, PTR, CHAR>

    TEMPREGS	<LNG, TPTR, TSTCHR>

RTNSTART

    ; Load "N" into the length register.  Take the faiure return
    ; if "N" is less-than-or-equal-to zero.
    SKIPG	LNG, N
    JRST	FAIL

    MOVE	TPTR, PTR
LOOP:
    MOVE	VR, TPTR
    ILDB	TSTCHR, TPTR
    CAME	TSTCHR, CHAR
    JRST	RETURN
    SOJG	LNG, LOOP
FAIL:
    SETZ	VR,
RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHFSU%
	ENTRY	CHFSU%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHFSU%')(CN, CPTR, PN, PPTR)
;
; FUNCTION:
;    Implements the CH$FIND_SUB character function for non-KL10
;    machines.
;
; INPUTS:
;    CN --	The length of the character string.
;    CPTR --	Pointer to the first character of the character string.
;    PN --	The length of the sub-string.
;    PPTR --	Pointer to the first character of the sub-string.
;
; OUTPUTS:
;    VALUE --	A character pointer to the first character of the first
;		occurence of the sub-string in the character string.
;		If the sub-string does not occur in the character, the
;		VALUE is the failure string pointer (0).
;
; OTHER ROUTINES USED:
;    CHCMP%
;-

GLOBAL ROUTINE CHFSU%, <CN, CPTR, PN, PPTR>

    TMP==	VR
    CHAR==	VR
    SAVEREGS	<NEWLNG, SAVPTR>
    STKLOCALS	<FCHAR, VALPTR>

RTNSTART

    ; If null sub-string do fast return.
    SKIPN	PN
    JRST	FSTRET

    ; We need only look at sub-strings starting on or before the
    ; NEWLNG'th character.
    MOVE	NEWLNG, CN
    SUB		NEWLNG, PN

    ; If the sub-string is longer than the character string then fail.
    SKIPGE	NEWLNG
    JRST	FAIL

    ; Get the first character of the sub-string.
    MOVE	TMP, PPTR
    ILDB	TMP, TMP
    MOVEM	TMP, FCHAR

    ; Copy CPTR to a local where it may be safely incremented.
    MOVE	TMP, CPTR
    MOVEM	TMP, VALPTR

    ; Loop until the first character is matched.
LOOP:
    MOVE	SAVPTR, VALPTR
    ILDB	CHAR, SAVPTR

    CAME	CHAR, FCHAR
    JRST	NOMATCH

    ; Use CH$COMPARE to see if the rest of the sub-string agrees.
    CALLSTART
	PUSHER	PN
	PUSHER	VALPTR
	PUSHER	PN
	PUSHER	PPTR
	PUSHER	[0]
    CALLER	CHCMP%##
    JUMPE	VR, MATCH

NOMATCH:
    SOJL	NEWLNG, FAIL
    MOVE	TMP, SAVPTR
    MOVEM	TMP, VALPTR
    JRST	LOOP

    ; We have found a complete match.
MATCH:
    MOVE	VR, VALPTR
    JRST	RETURN

FSTRET:
    ; Null match: fast return.
    MOVE	VR, CPTR
    JRST	RETURN

FAIL:
    SETZ	VR,
RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHFSX%
	ENTRY	CHFSX%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHFSX%')(CN, CPTR, PN, PPTR)
;
; FUNCTION:
;    Implements the CH$FIND_SUB character function for KL10
;    machines.
;
; INPUTS:
;    CN --	The length of the character string.
;    CPTR --	Pointer to the first character of the character string.
;    PN --	The length of the sub-string.
;    PPTR --	Pointer to the first character of the sub-string.
;
; OUTPUTS:
;    VALUE --	A character pointer to the first character of the first
;		occurence of the sub-string in the character string.
;		If the sub-string does not occur in the character, the
;		VALUE is the failure string pointer (0).
;-

GLOBAL ROUTINE CHFSX%, <CN, CPTR, PN, PPTR>

    TMP==	VR
    CHAR==	VR
    SAVEREGS	<NEWLNG, SAVPTR>
    STKLOCALS	<FCHAR, VALPTR>
    ADJREGS	<AC1, AC2, AC3, AC4, AC5>

RTNSTART

    ; If null sub-string: do a fast return.
    SKIPN	PN
    JRST	FSTRET

    ; We need only look at sub-strings starting on or before the
    ; NEWLNG'th character.
    MOVE	NEWLNG, CN
    SUB		NEWLNG, PN

    ; If the sub-string is longer than the character string: fail.
    SKIPGE	NEWLNG
    JRST	FAIL

    ; Get the first character of the sub-string.
    MOVE	TMP, PPTR
    ILDB	TMP, TMP
    MOVEM	TMP, FCHAR

    ; Put CPTR in a local where we may safely increment it.
    MOVE	TMP, CPTR
    MOVEM	TMP, VALPTR

    ; Loop until the first character is matched.
LOOP:
    MOVE	SAVPTR, VALPTR
    ILDB	CHAR, SAVPTR

    CAME	CHAR, FCHAR
    JRST	NOMATCH

    ; Use CH$COMPARE to see if the rest of the sub-string agrees.
    MOVE	AC1, PN
    MOVE	AC2, VALPTR
    MOVE	AC4, AC1
    MOVE	AC5, PPTR
    EXTEND	AC1, [EXP	CMPSN, 0, 0]
    JRST	MATCH

NOMATCH:
    SOJL	NEWLNG, FAIL
    MOVE	TMP, SAVPTR
    MOVEM	TMP, VALPTR
    JRST	LOOP

    ; We have found a complete match.
MATCH:
    MOVE	VR, VALPTR
    JRST	RETURN

FSTRET:
    ; Null match: fast return.
    MOVE	VR, CPTR
    JRST	RETURN

FAIL:
    SETZ	VR,
RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHMOV%
	ENTRY	CHMOV%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHMOV%')(N, SPTR, DPTR)
;
; FUNCTION:
;    Implements the CH$MOVE character function.
;
; INPUTS:
;    N --	The number of characters to be transfered.
;    SPTR --	A pointer to the first character to be transfered.
;    DPTR --	A pointer to the location to which the first character
;		is to be transfered.
;
; OUTPUTS:
;    VALUE --	A character pointer to the character following the
;		last character transferred, i.e. CH$PLUS(DPTR, N + 1).
;-

GLOBAL ROUTINE CHMOV%, <N, SPTR, DPTR>

    TEMPREGS	<LNG, SRC, TMP>
    DST==	VR

RTNSTART

    MOVE	LNG, N
    MOVE	SRC, SPTR
    MOVE	DST, DPTR
    JRST	LTEST

LOOP:
    ILDB	TMP, SRC
    IDPB	TMP, DST
LTEST:
    SOJGE	LNG, LOOP

RTNEND

	LIT
	PRGEND
	TITLE	CHFIL%
	ENTRY	CHFIL%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHFIL%')(FILL, DN, DPTR)
;
; FUNCTION:
;    Implement the CH$FILL character function.
;
; INPUTS:
;    FILL --	The value of the character to be used as fill.
;    DN --	The number of characters to be filled.
;    DPTR --	The position of the first character to be filled.
;
; OUTPUTS:
;    VALUE --	A pointer to the first character after "DPTR" which
;		was not filled, i.e. CH$PLUS(DPTR, DN + 1).
;-

GLOBAL ROUTINE CHFIL%, <FILL, DN, DPTR>

    TEMPREGS	<LNG, CHAR>
    DEST==	VR

RTNSTART
    MOVE	LNG, DN
    MOVE	CHAR, FILL
    MOVE	DEST, DPTR
    JRST	LTEST

LOOP:
    IDPB	CHAR, DEST
LTEST:
    SOJGE	LNG, LOOP
RTNEND

	LIT
	PRGEND
	TITLE	CHCOP%
	ENTRY	CHCOP%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHCOP%')(SN1, SPTR1, SN2, SPTR2, . . . , SNN, SPTRN,
;	FILL, DN, DPTR, ARGCNT)
;
; FUNCTION:
;    Implements the CH$COPY character function.
;
; INPUTS:
;    SN1, SN2, . . . SNN --	The lengths of the source strings.
;    SPTR1, SPTR2, . . . SPTRN --	The positions of the first
;		characters of the source strings.
;    FILL --	The fill character to be used if the sum of the
;		source lengths is less than the destination length.
;    DN --	The total number of characters to be transfered from
;		the source strings or filled.
;    DPTR --	The position of the first character to be copied into.
;    ARGCNT --	The negative of the number of other arguments.  It
;		is equal to -(2*N + 3) where N is the number of source
;		strings.
;
; OUTPUTS:
;    VALUE --	A character pointer to the character following the last
;		character position copied to, i.e.
;		CH$PLUS(DPTR, DN + 1).
;-

GLOBAL ROUTINE CHCOP%, <ARGUMENT>

    TEMPREGS	<INDX, TMP, DLNGTH, TRNSFR, SRC>
    DST== VR
    INITDY

RTNSTART

    ; Initialize.
    IFN APFLAG,
	<
	MOVE	INDX, ARG%CNT
	ADD	INDX, [4,,0]
	HRRI	INDX, ARGUMENT
	HLRE	TMP, ARG%CNT
	MOVM	TMP, TMP
	ADDI	TMP, ARG%CNT
	>
    IFE APFLAG,
	<
	MOVE	INDX, ARGUMENT
	ADDI	INDX, ARGUMENT
	HRL	INDX, ARGUMENT
	ADD	INDX, [4,,0]
	MOVEI	TMP, ARGUMENT
	>

    PUSHER	-3(TMP)
    MOVE	DLNGTH, -2(TMP)
    MOVE	DST, -1(TMP)

    ; Move each source string in turn.
ILOOP:
    JUMPLE	DLNGTH, RETURN
    MOVE	TRNSFR, 0(INDX)
    CAMLE	TRNSFR, DLNGTH
    MOVE	TRNSFR, DLNGTH

    SUB		DLNGTH, TRNSFR

    ; Do CH$MOVE.
    MOVE	SRC, 1(INDX)
    JRST	MLTEST
MLOOP:
    ILDB	TMP, SRC
    IDPB	TMP, DST
MLTEST:
    SOJGE	TRNSFR, MLOOP

    ; INCREMENT INDX, AND TEST
    ADD	INDX, [1,,1]
    AOBJN	INDX, ILOOP

    JUMPLE	DLNGTH, RETURN

    ; Do CH$FILL
    MOVE	TMP, DYTEMP<0>
FLOOP:
    IDPB	TMP, DST
    SOJG	DLNGTH, FLOOP
RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHCMP%
	ENTRY	CHCMP%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >
;+
; CALLING SEQUENCE (BLISS):
;    %NAME('CHCMP%')(N1, PTR1, N2, PTR2, FILL)
;
; FUNCTION:
;    Implements the CH$COMPARE character function.  This is used to
;    implement the character functions CH$GTR, CH$GEQ, CH$EQL, CH$LEQ,
;    CH$LSS, CH$NEQ.
;
; INPUTS:
;    N1 --	The length of the first string to be compared.
;    PTR1 --	The position of the first character of the first
;		comparison string.
;    N2 --	The length of the second string to be compared.
;    PTR2 --	The position of the first character of the second
;		comparison string.
;    FILL --	The character to be used to fill out the shorter
;		string durring the comparison.
;
; OUTPUTS:
;    VALUE --	-1 if the first string is less than the second.
;		0 if the strings are equal.
;		+1 if the first string is greater than the second.
;-

GLOBAL ROUTINE CHCMP%, <N1, PTR1, N2, PTR2, FILL>

    TEMPREGS	<LNG1, LNG2, CHR1, CHR2, MAXLNG>
    STKLOCALS	<SRC1, SRC2>
    TMP== VR

RTNSTART

    ; See if the strings are of the same length.
    MOVE	LNG1, N1
    CAME	LNG1, N2
    JRST	NEQLNG

    ; They are the same length, if that length is zero than they are
    ; equal without any further comparison.
    JUMPLE	LNG1, RETEQL
    MOVE	TMP, PTR1
    MOVEM	TMP, SRC1
    MOVE	TMP, PTR2
    MOVEM	TMP, SRC2

LOOP1:
    ILDB	CHR1, SRC1
    ILDB	CHR2, SRC2
    CAME	CHR1, CHR2
    JRST	RETNEQ		; We have found a mis-match.

    ; Test and loop.
    SOJG	LNG1, LOOP1

    ; If we fall through the loop, the strings are equal.
RETEQL:
    SETZ	VR,
    JRST	RETURN

    ; We come here if the strings are of unequal length.
NEQLNG:

    MOVE	LNG2, N2

    ; Find the maximum length so we know when to quit comparing.
    MOVE	MAXLNG, LNG1
    CAMGE	MAXLNG, LNG2
    MOVE	MAXLNG, LNG2

    ; If the maximum length is zero, the strings are equaly null.
    JUMPLE	MAXLNG, RETEQL

    MOVE	TMP, PTR1
    MOVEM	TMP, SRC1
    MOVE	TMP, PTR2
    MOVEM	TMP, SRC2

LOOP2:
    ; Temporarily assume that both comparisons will use the fill
    ; character.
    MOVE	CHR1, FILL
    MOVE	CHR2, CHR1

    ; Get the correct character if there is any left.
    SOSL	LNG1
    ILDB	CHR1, SRC1
    SOSL	LNG2
    ILDB	CHR2, SRC2

    CAME	CHR1, CHR2
    JRST	RETNEQ
    SOJG	MAXLNG, LOOP2

    SETZ	VR,
    JRST	RETURN

RETNEQ:
    ; We have found unequal characters.  Do an unsigned comparison.
    SETO	VR,
    TLC		CHR1,400000
    TLC		CHR2,400000
    CAML	CHR1, CHR2
    MOVEI	VR, 1
RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHTRA%
	ENTRY	CHTRA%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME(CHTRA%)(TAB, SN, SPTR, FILL, DN, DPTR)
;
; FUNCTION:
;    Implements the CH$TRANSLATE character function.
;
; INPUTS:
;    TAB --	The address of the translation table.
;    SN --	The length of the source string.
;    SPTR --	The location of the first character of the source
;		string.
;    FILL --	The character to fill the destination out with if
;		DN is greater than SN.
;    DN --	The length of the destination string.
;    DPTR --	The location of the first character of the destination
;		string.
;-

GLOBAL ROUTINE CHTRA%, <TAB, SN, SPTR, FILL, DN, DPTR>

    TEMPREGS	<DLNGTH, DST, SLNGTH, SRC, CHR, TTABLE>

RTNSTART
    MOVE	DST, DPTR
    MOVE	DLNGTH, DN

    ; Return immediatly if destination string is null.
    JUMPLE	DLNGTH, RETURN

    MOVE	SRC, SPTR
    MOVE	SLNGTH, SN
    MOVE	TTABLE, TAB

LOOP:
    SOJL	SLNGTH, DOFILL
    ILDB	CHR, SRC

    ; Put half the character value in the right half, save the parity
    ; (i.e. low order) bit in the left half.
    ROT		CHR, -1

    ; CHR will now point to a pair of (half-word) entries in the
    ; translation table.
    ADDI	CHR, (TTABLE)

    ; Choose the left or right halves of the table-word depending on
    ; the parity of the orriginal character, now stored as the sign
    ; bit of CHR.
    JUMPL	CHR, ODD
    HLRZ	CHR, (CHR)
    SKIPA
ODD:
    HRRZ	CHR, (CHR)

    ; Load the new character into the destination string, increment
    ; test and loop.
    IDPB	CHR, DST
    SOJG	DLNGTH, LOOP

    ; We have used up the destination string, exit.
    JRST	RETURN

DOFILL:
    ; The source string is exhasted but there are unfilled charcters
    ; left in the destination string.  Fill them.
    MOVE	CHR, FILL
FLOOP:
    IDPB	CHR, DST
    SOJG	DLNGTH, FLOOP

RETURN:

RTNEND

	LIT
	PRGEND
	TITLE	CHSIZ%
	ENTRY 	B36CHSIZ
	ENTRY	CHSIZ%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >
	B36CHSIZ==CHSIZ%

;+
; CALLING SEQUENCE (BLISS):
;    %NAME(CHSIZ%)(PTR)
;
; FUNCTION:
;	This routine returns the size of a given pointer.
;
; INPUTS:
;    PTR -- A pointer or at least the 'P' field of a 1 word global
;		byte pointer in leftmost part of the word.
;
; OUTPUTS:
;    VALUE --    The size.
;-

GLOBAL ROUTINE CHSIZ%, <PTR>

RTNSTART
    MOVE	VR, PTR
    LSH		VR, -^D30		; Get 'P'
    SUBI	VR, ^D37		; Check if it is a 1-word global byte ptr.
    JUMPL	VR, LOCAL		
    MOVE	VR, SIZE(VR)		; Get the size for this global byte ptr.
    JRST	RETURN			; Return to the caller.
;Here if LOCAL byte pointer
LOCAL:
    MOVE	VR, PTR
    ASH		VR, -^D24
    ANDI	VR, 77

RETURN:

RTNEND

;
; SIZE - Table used to get the size field of a 1-word
;	 global byte pointer. It is indexed by 37-'P'.
;

SIZE:
	EXP <6>
	EXP <6>
	EXP <6>
	EXP <6>
	EXP <6>
	EXP <6>
	EXP <6>
	EXP <^D8>
	EXP <^D8>
	EXP <^D8>
	EXP <^D8>
	EXP <^D8>
	EXP <7>
	EXP <7>
	EXP <7>
	EXP <7>
	EXP <7>
	EXP <7>
	EXP <^D9>
	EXP <^D9>
	EXP <^D9>
	EXP <^D9>
	EXP <^D9>
	EXP <^D18>
	EXP <^D18>
	EXP <^D18>
	EXP <77>

	LIT
	PRGEND
	TITLE	CVTDF%
	ENTRY	CVTDF%
	SEARCH	$OTSDE
IFE PSECTFLG
    <
     TWOSEG
     RELOC 400000
    >

IFN PSECTFLG
    <
     PSECTCODE
    >

;+
; CALLING SEQUENCE (BLISS):
;    %NAME(CVTDF%)(DSRCA)
;
; FUNCTION:
;    Implements the CVTDF floating-point function.
;
; INPUTS:
;    DSRCA --    The address of the double-precision number.
;
; OUTPUTS:
;    VALUE --    The single-precision number.
;-

GLOBAL ROUTINE CVTDF%, <DSRCA>

    ADJREGS	<AC1,AC2>

RTNSTART
    MOVE	AC1, DSRCA
    DMOVE 	AC1, (AC1)
	JUMPL	AC1, CVT1
	CAMN 	AC1, [377777,,777777]	;Special case - largest possible number
	JRST 	LEAVE
    TLNE	AC2, 200000
    TRON	AC1, 1
    JRST	LEAVE
    MOVE	AC2, AC1
    AND		AC1, [-1000,,1] 
    FADR	AC1, AC2
    JRST	LEAVE
CVT1:CAMN	AC1, [400000,,000000]	;Special case - most negative number
	JRST	LEAVE
	DMOVN	AC1, AC1
    TLNE	AC2, 200000
    TRON	AC1, 1
    JRST	CVT2
    MOVN	AC2, AC1
    ORCA	AC1, [777,,777777]
    FADR	AC1, AC2
    JRST	LEAVE
CVT2:MOVN	AC1, AC1

LEAVE:MOVE	VR, AC1
RTNEND

	LIT
	END