Upload

Digital Research

CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/get.plm

@@ -0,0 +1,939 @@
+$ TITLE('CP/M 3.0 --- GET user interface')
+get:
+do;
+
+/*
+  Copyright (C) 1982
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+*/
+
+/*
+Written:  30 July 82  by John Knight 
+          12 Sept 82  by Doug Huskey
+*/
+
+/********************************************
+*                                           *
+*       LITERALS AND GLOBAL VARIABLES       *
+* 					    *
+********************************************/
+
+declare
+    true    		literally '1',
+    false   		literally '0',
+    forever 		literally 'while true',
+    lit     		literally 'literally',
+    proc    		literally 'procedure',
+    dcl     		literally 'declare',
+    addr    		literally 'address',
+    cr      		literally '13',
+    lf      		literally '10',
+    ctrlc   		literally '3',
+    ctrlx   		literally '18h',
+    bksp    		literally '8',
+    con$type		literally '0',
+    aux$type		literally '1',
+    con$width$offset	literally '1ah',
+    ccp$flag$offset	literally '18h',
+    get$rsx$init        literally '128',
+    get$rsx$kill        literally '129',
+    get$rsx$fcb         literally '130',
+    cpmversion		literally '30h';
+    
+  declare ccp$flag byte;
+  declare con$width byte;
+  declare i byte;
+  declare begin$buffer address;
+  declare buf$length byte;
+  declare no$chars byte;
+  declare get$init$pb byte initial(get$rsx$init);
+  declare get$kill$pb byte initial(get$rsx$kill);
+  declare get$fcb$pb byte initial(get$rsx$fcb);
+  declare input$type byte;
+ 
+  declare
+    sub$fcb (*)   byte data (0,'SYSIN   $$$'),
+    get$msg (*)   byte data ('Getting console input from $');
+
+  /* scanner variables and data */
+  declare
+    options(*) byte data
+        ('INPUT~FROM~FILE~STATUS~CONDITIONAL~',
+         'FALSE~TRUE~CONSOLE~CONIN:~AUXILIARY~',
+         'AUXIN:~END~CON:~AUX:~NOT~ECHO~FILTERED~SYSTEM~PROGRAM',0FFH),
+		
+    options$offset(*) byte data
+        (0,6,11,16,23,35,41,46,54,61,71,78,82,87,92,96,101,110,117,124),
+
+    end$list	byte data (0ffh),
+
+    delimiters(*) byte data (0,'[]=, ./;',0,0ffh),
+
+    SPACE	byte data(5),
+
+    buf$ptr	address,
+    index	byte,
+    endbuf	byte,
+    j		byte initial(0),
+    delimiter	byte;
+    
+    declare end$of$string byte initial ('~');
+
+  declare getpb structure
+    (input$type   byte,
+     echo$flag     byte,
+     filtered$flag byte,
+     program$flag  byte)
+    initial(con$type,true,true,true);
+
+  declare scbpd structure
+    (offset byte,
+     set    byte,
+     value  address);
+
+  declare parse$fn structure
+    (buff$adr address,
+     fcb$adr  address);
+
+ declare plm label public;
+ 
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  mon1:
+    procedure (func,info) external;
+      declare func byte;
+      declare info address;
+    end mon1;
+
+  mon2:
+    procedure (func,info) byte external;
+      declare func byte;
+      declare info address;
+    end mon2;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  printchar: 
+    procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+  conin:
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+  read$console$buf:
+    procedure (buffer$address,max) byte;
+    declare buffer$address address;
+    declare new$max based buffer$address address;
+    declare max byte;
+    new$max = max;
+    call mon1(10,buffer$address);
+    buffer$address = buffer$address + 1;
+    return new$max;	/* actually number of characters input */
+  end read$console$buf;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  check$con$stat: procedure byte;
+    return mon2(11,0);
+  end check$con$stat;
+
+  open$file:
+    procedure (fcb$address) address;
+    declare fcb$address address;
+    return mon3(15,fcb$address);
+  end open$file;
+
+  set$dma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+  end set$dma;
+
+  /* 0ffh ==> return BDOS errors */
+  return$errors: procedure (mode);
+    declare mode byte;
+    call mon1(45,mode);
+  end return$errors;
+
+  getscbbyte: procedure (offset) byte;
+    declare offset byte;
+    scbpd.offset = offset;
+    scbpd.set = 0;
+    return mon2(49,.scbpd);
+  end getscbbyte;
+
+  setscbbyte:
+    procedure (offset,value);
+    declare offset byte;
+    declare value byte;
+    scbpd.offset = offset;
+    scbpd.set = 0ffh;
+    scbpd.value = double(value);
+    call mon1(49,.scbpd);
+  end setscbbyte;
+
+get$console$mode: procedure address;
+/* returns console mode */
+  return mon3(6dh,0ffffh);
+end get$console$mode;
+
+set$console$mode: procedure (new$value);
+  declare new$value address;
+  call mon1(6dh,new$value);
+end set$console$mode;
+
+rsx$call: procedure (rsxpb) address;
+/* call Resident System Extension */
+  declare rsxpb address;
+  return mon3(60,rsxpb);
+end rsx$call;
+
+parse: procedure (pfcb) address external;
+  declare pfcb address;
+end parse;
+
+getf: procedure (input$type) external;
+        declare input$type address;
+end getf;
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                    * * *  Option scanner  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+separator: procedure(character) byte;
+
+					/* determines if character is a 
+					   delimiter and which one */
+	declare	k	byte,
+		character	byte;
+
+	k = 1;
+loop:	if delimiters(k) = end$list then return(0);
+	if delimiters(k) = character then return(k);	/* null = 25 */
+		k = k + 1;
+		go to loop;
+
+end separator;
+
+opt$scanner:	procedure(list$ptr,off$ptr,idx$ptr);
+					/* scans the list pointed at by idxptr
+					   for any strings that are in the 
+					   list pointed at by list$ptr.
+					   Offptr points at an array that 
+					   contains the indices for the known
+					   list. Idxptr points at the index 
+					   into the list. If the input string
+					   is unrecognizable then the index is
+				   	   0, otherwise > 0.
+
+					First, find the string in the known
+					list that starts with the same first 
+					character.  Compare up until the next
+					delimiter on the input. if every input
+					character matches then check for 
+					uniqueness.  Otherwise try to find 
+					another known string that has its first
+					character match, and repeat.  If none
+					can be found then return invalid.
+
+					To test for uniqueness, start at the 
+					next string in the knwon list and try
+					to get another match with the input.
+					If there is a match then return invalid.
+
+					else move pointer past delimiter and 
+					return.
+
+				P.Balma		*/
+
+	declare
+		buff		based buf$ptr (1) byte,
+		idx$ptr		address,
+		off$ptr		address,
+		list$ptr	address;
+
+	declare
+		i		byte,
+		j		byte,
+		list		based list$ptr (1) byte,
+		offsets		based off$ptr (1) byte,
+		wrd$pos  	byte,
+		character	byte,
+		letter$in$word	byte,
+		found$first	byte,
+		start		byte,
+		index		based idx$ptr byte,
+		save$index	byte,
+		(len$new,len$found)	byte,
+		valid		byte;
+
+/*****************************************************************************/
+/*			internal subroutines				     */
+/*****************************************************************************/
+
+check$in$list: procedure;
+				/* find known string that has a match with 
+				   input on the first character.  Set index
+				   = invalid if none found.   */
+			
+	declare	i	byte;
+
+	i = start;
+	wrd$pos = offsets(i);
+	do while list(wrd$pos) <> end$list;
+		i = i + 1;
+		index = i;
+		if list(wrd$pos) = character then return;
+		wrd$pos = offsets(i);
+	end;
+			/* could not find character */
+	index = 0;
+	return;
+end check$in$list;
+
+setup:	procedure;
+	character = buff(0);
+	call check$in$list;
+	letter$in$word = wrd$pos;
+			/* even though no match may have occurred, position
+			   to next input character.  */
+	i = 1;
+	character = buff(1);
+end setup;
+
+test$letter:	procedure;
+			/* test each letter in input and known string */
+
+	letter$in$word = letter$in$word + 1;
+
+					/* too many chars input? 0 means
+					   past end of known string */
+	if list(letter$in$word) = end$of$string then valid = false;
+	else
+	if list(letter$in$word) <> character then valid = false;
+
+	i = i + 1;
+	character = buff(i);
+
+end test$letter;
+
+skip:	procedure;
+					/* scan past the offending string;
+					   position buf$ptr to next string...
+					   skip entire offending string;
+					   ie., falseopt=mod, [note: comma or
+					   space is considered to be group 
+					   delimiter] */
+	character = buff(i);
+	delimiter = separator(character);
+	/* No skip for GET */
+        do while ((delimiter < 1) or (delimiter > 9));
+		i = i + 1;
+		character = buff(i);
+		delimiter = separator(character);
+	end;
+	endbuf = i;
+	buf$ptr = buf$ptr + endbuf + 1;
+	return;
+end skip;
+
+eat$blanks: procedure;
+
+	declare	charac	based buf$ptr byte;
+
+
+	do while ((delimiter := separator(charac)) = SPACE);
+		buf$ptr = buf$ptr + 1;
+	end;
+
+end eat$blanks;
+
+/*****************************************************************************/
+/*			end of internals				     */
+/*****************************************************************************/
+
+
+					/* start of procedure */
+	if delimiter = 9 then
+		return;
+	call eat$blanks;
+	start = 0;
+	call setup;
+
+					/* match each character with the option
+					   for as many chars as input 
+					   Please note that due to the array
+					   indices being relative to 0 and the
+					   use of index both as a validity flag
+					   and as a index into the option/mods
+					   list, index is forced to be +1 as an
+					   index into array and 0 as a flag*/
+
+	do while index <> 0;
+		start = index;
+		delimiter = separator(character);
+
+					/* check up to input delimiter */
+
+		valid = true;		/* test$letter resets this */
+		do while delimiter = 0;
+			call test$letter;
+			if not valid then go to exit1;
+			delimiter = separator(character);
+		end;
+
+		go to good;
+
+					/* input ~= this known string;
+					   get next known string that 
+					   matches */
+exit1:		call setup;
+	end;
+					/* fell through from above, did
+					   not find a good match*/
+	endbuf = i;			/* skip over string & return*/
+	call skip;
+	return;
+
+					/* is it a unique match in options
+					   list? */
+good:	endbuf = i;
+	len$found = endbuf;
+	save$index = index;
+	valid = false;
+next$opt:
+		start = index;
+		call setup;
+		if index = 0 then go to finished;
+
+					/* look at other options and check
+					   uniqueness */
+
+		len$new = offsets(index + 1) - offsets(index) - 1;
+		if len$new = len$found then do;
+			valid = true;
+			do j = 1 to len$found;
+				call test$letter;
+				if not valid then go to next$opt;
+			end;
+		end;
+		else go to nextopt;
+					/* fell through...found another valid
+					   match --> ambiguous reference */
+	index = 0;
+	call skip;		/* skip input field to next delimiter*/
+	return;
+
+finished:			/* unambiguous reference */
+	index = save$index;
+	buf$ptr = buf$ptr + endbuf;
+	call eat$blanks;
+	if delimiter <> 0 then
+          buf$ptr = buf$ptr + 1;
+        else
+          delimiter = 5;
+	return;
+
+end opt$scanner;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+/* fill string @ s for c bytes with f */
+fill: procedure(s,f,c);
+  declare s address;
+  declare (f,c) byte;
+  declare a based s byte;
+  do while (c:=c-1) <> 255;
+    a=f;
+    s=s+1;
+  end;
+end fill;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+/* The error processor.  This routine prints the command line
+  with a carot '^' under the offending delimiter, or sub-string.
+  The code passed to the routine determines the error message
+  to be printed beneath the command string.                  */
+
+error: procedure (code);
+  declare (code,i,j,nlines,rem) byte;
+  declare (string$ptr,tstring$ptr) address;
+  declare chr1 based string$ptr byte;
+  declare chr2 based tstring$ptr byte;
+  declare carot$flag byte;
+
+print$command: procedure (size);
+  declare size byte;
+  do j=1 to size;	/* print command string */
+    call printchar(chr1);
+    string$ptr = string$ptr + 1;
+  end;
+  call crlf;
+  do j=1 to size;	/* print carot if applicable */
+    if .chr2 = buf$ptr then do;
+      carot$flag = true;
+      call printchar('^');
+    end;
+    else
+      call printchar(' ');
+    tstring$ptr = tstring$ptr + 1;
+  end;
+  call crlf;
+end print$command;
+
+  carot$flag = false;
+  string$ptr,tstring$ptr = begin$buffer;
+  con$width = getscbbyte(con$width$offset);
+  if con$width < 40 then con$width = 40;
+  nlines = buf$length / con$width;	/* num lines to print */
+  rem = buf$length mod con$width;	/* num extra chars to print */
+  if code <> 2 then do;
+    if ((code = 1) or (code = 4)) then	/* adjust carot pointer */
+      buf$ptr = buf$ptr - 1;	/* for delimiter errors */
+    else if code <> 5 then
+      buf$ptr = buf$ptr - endbuf - 1;	/* all other errors */
+  end;
+  call crlf;
+  do i=1 to nlines;
+    tstring$ptr = string$ptr;
+    call print$command(con$width);
+  end;
+  call print$command(rem);
+  if carot$flag then
+    call print$buf(.('Error at the ''^'': $'));
+  else
+    call print$buf(.('Error at end of line: $'));
+  if con$width < 65 then
+    call crlf;
+  do case code;
+    call print$buf(.('Invalid option or modifier$'));
+    call print$buf(.('End of line expected$'));
+    call print$buf(.('Invalid file specification$'));
+    call print$buf(.('Invalid command$'));
+    call print$buf(.('Invalid delimiter$'));
+    call print$buf(.('File not found$'));
+  end;
+  call crlf;
+  call mon1(0,0);
+end error;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+ucase: procedure (char) byte;
+  declare char byte;
+  if char >= 'a' then
+    if char < '{' then
+      return (char-20h);
+  return char;
+end ucase;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+getucase: procedure byte;
+  declare c byte;
+  c = ucase(conin);
+  return c;
+end getucase;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+getpasswd: procedure;
+  declare (i,c) byte;
+  call crlf;
+  call crlf;
+  call print$buf(.('Enter Password: $'));
+retry:
+  call fill(.fcb16,' ',8);
+  do i=0 to 7;
+nxtchr:
+  if (c:=getucase) >= ' ' then
+    fcb16(i)=c;
+  if c = cr then 
+    go to exit;
+  if c = ctrlx then
+    go to retry;
+  if c = bksp then do;
+    if i < 1 then
+      goto retry;
+    else do;
+      fcb16(i := i - 1) = ' ';
+      goto nxtchr;
+      end;
+    end;
+  if c = 3 then
+    call mon1(0,0);
+  end;
+exit:
+  c = check$con$stat;	/* clear raw i/o mode */
+end getpasswd;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+print$fn: procedure (fcb$ad);
+  declare k byte;
+  declare fcb$ad address;
+  declare driv based fcb$ad byte;
+  declare fn based fcb$ad (12) byte;
+
+  call print$buf(.('file: $'));
+  if driv <> 0 then do;
+    call printchar('@'+driv);
+    call printchar(':');
+  end;
+  do k=1 to 11;
+    if k=9 then
+      call printchar('.');
+    if fn(k) <> ' ' then
+      call printchar(fn(k) and 07fh);
+  end;
+end print$fn;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+try$open: procedure;
+  declare (error$code,a) address;
+  declare prog$flag based a byte;
+  declare code byte;
+
+  
+  error$code = rsx$call(.get$fcb$pb);
+  if error$code <> 0ffh then do; /* 0ffh means no active get */
+    a = error$code - 2;
+    if prog$flag then            /* program input only? */
+      error$code = rsx$call(.get$kill$pb); /* kill if so */
+  end;
+  call setdma(.fcb16);	/* set dma to password */
+  call return$errors(0ffh);
+  error$code = open$file(.fcb);
+  call return$errors(0);
+  if low(error$code) = 0ffh then
+    if (code := high(error$code)) <> 0 then do;
+      if code = 7 then do;
+        call getpasswd;
+        call crlf;
+        call setdma(.fcb16);
+      end;
+      error$code=open$file(.fcb);
+    end;
+    else do;
+      buf$ptr = parse$fn.buff$adr;	/* adjust pointer to file */
+      call error(5);	/* file not found */
+    end;
+  call print$buf(.get$msg);
+  if getscbbyte(26) < 48 then
+    call crlf;				/* console width */
+  call print$fn(.fcb);
+  call getf(.getpb);
+end try$open;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+submit: procedure(adr) byte;
+  declare adr address;
+  declare fn based adr (12) byte;
+  declare (i,match) byte;
+
+  compare: procedure(j);
+    dcl j byte;
+    if (fn(j) and 07fh) = sub$fcb(j) then
+      return;
+    match = false;
+  end compare;
+
+  match = true;
+    do i = 1 to 3;	/* sub = SYS     $$$ */
+    call compare(i);
+    call compare(i+8);
+    end;
+  return match;
+end submit;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+kill$rsx: procedure;
+  declare (fcb$adr,a) address;
+
+  if delimiter <> 9 then	/* check for eoln */
+    call error(1);
+  /* remove SUBMIT & GET rsx modules */
+  do while (fcb$adr:=rsx$call(.get$fcb$pb)) <> 0ffh;
+    a = rsx$call(.get$kill$pb);
+    if submit(fcb$adr) then
+      call print$buf(.('SUBMIT of $'));
+    else
+      call print$buf(.('GET  from $'));
+    call print$fn(fcb$adr);
+    call print$buf(.(' stopped$'));
+    call crlf;
+  end;
+  call print$buf(.get$msg);
+  call print$buf(.('console$'));
+  call mon1(0,0);
+end kill$rsx;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+end$rsx: procedure;
+  declare (a,fcb$adr) address;
+
+  if delimiter <> 9 then	/* check for eoln */
+    call error(1);
+  if (fcb$adr := rsx$call(.get$fcb$pb)) <> 0ffh then 
+    if not submit(fcb$adr) then do;
+      a = rsx$call(.get$kill$pb);
+      call print$buf(.('GET  from $'));
+      call print$fn(fcb$adr);
+      call print$buf(.(' stopped$'));
+      call crlf;
+    end;
+
+  /* determine where console input comes from now */
+  call print$buf(.get$msg);
+  fcb$adr = rsx$call(.get$fcb$pb);
+  if fcb$adr = 0ffh then
+    call print$buf(.('console$'));
+  else do;
+    if getscbbyte(26) < 48 then
+      call crlf;				/* console width */
+    call print$fn(fcb$adr);
+  end;
+  call mon1(0,0);
+end end$rsx;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+set$rsx$mode: procedure (bit$value);
+  declare bit$value byte;
+  declare temp address;
+  temp = get$console$mode;
+  temp = temp and 111111$00$11111111b;	/* mask off bits to be set */
+  if bit$value <> 0 then
+    temp = temp or (255 + bit$value);
+  call set$console$mode(temp);
+end set$rsx$mode;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+process$file: procedure(buf$adr);
+  declare negate byte;
+  declare status address;
+  declare buf$adr address;
+  declare char based status byte;
+  parse$fn.buff$adr = buf$adr;
+  parse$fn.fcb$adr = .fcb;
+  status = parse(.parse$fn);
+  if status = 0ffffh then
+    call error(2);	/* bad file */
+  if status = 0 then	/* eoln */
+    call try$open;	/* try$open does not return */
+  else
+    buf$ptr = status + 1;	/* position buf$ptr past '[' */
+  if char <> '[' then		/* PROCESS OPTIONS */
+    call error(4);
+  do while ((delimiter<>2) and (delimiter<>9));
+    call opt$scanner(.options(0),.options$offset(0),.index);
+    if index = 4 then do;	/* STATUS */
+      if delimiter <> 3 then	/* '=' */
+        call error(4);
+      call opt$scanner(.options(0),.options$offset(0),.index);
+      if index = 5 then		/* CONDITIONAL */
+        call set$rsx$mode(0);
+      else if index = 6 then	/* FALSE */
+        call set$rsx$mode(1);
+      else if index = 7 then	/* TRUE */
+        call set$rsx$mode(2);
+      else 
+        call error(0);		/* Not a valid option */
+    end;
+    else do;	/* ECHO, FILTER, & SYSTEM  options */
+      negate=false;
+      if index = 15 then do;
+        negate = true;
+        call opt$scanner(.options(0),.options$offset(0),.index);
+      end;
+      if index = 16 then do;            /* ECHO */
+        if negate then
+          getpb.echo$flag = false;
+        else
+          getpb.echo$flag = true;
+      end;
+      else if index = 17 then do;       /* FILTER */
+        if negate then
+          getpb.filtered$flag = false;
+        else
+          getpb.filtered$flag = true;
+      end;
+      else if index = 18 then do;       /* SYSTEM */
+        if negate then
+          getpb.program$flag = true;
+        else
+          getpb.program$flag = false;
+      end;
+      else if index = 19 then do;       /* PROGRAM */
+        if negate then
+          getpb.program$flag = false;
+        else
+          getpb.program$flag = true;
+      end;
+      else
+        call error(0);
+    end;
+  end;
+  call try$open;	/* all set up, so do open */
+end process$file;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+input$found: procedure (buffer$adr) byte;
+  declare buffer$adr address;
+  declare char based buffer$adr byte;
+  do while (char = ' ') or (char = 9); /* tabs & spaces */
+    buffer$adr = buffer$adr + 1;
+  end;
+  if char = 0 then	/* eoln */
+    return false;	/* input not found */
+  else
+    return true;	/* input found */
+end input$found;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+ 
+/*********************************
+*                                *
+*    M A I N   P R O G R A M     *
+*                                *
+*********************************/
+
+plm:
+  do;
+    if (low(version) < cpmversion) or (high(version)=1) then do;
+      call print$buf(.('Requires CP/M 3.0$'));
+      call mon1(0,0);
+    end;
+    if not input$found(.tbuff(1)) then do;	/* just GET */
+      call print$buf(.('CP/M 3 GET Version 3.0',cr,lf,'$'));
+      call print$buf(.('Get console input from a file',cr,lf,'$'));
+      call print$buf(.('Enter file: $'));
+      no$chars = read$console$buf(.tbuff(0),128);
+      call crlf;
+      tbuff(1) = ' ';		/* blank out nc field */
+      tbuff(no$chars+2) = 0;	/* mark eoln */
+      if not input$found(.tbuff(1)) then	/* quit, no file name */
+        call mon1(0,0);
+      do i=1 to no$chars;	/* make input capitals */
+        tbuff(i+1) = ucase(tbuff(i+1));
+      end;
+      begin$buffer = .tbuff(2);
+      buf$length = no$chars;
+      buf$ptr = .tbuff(2);
+      call process$file(.tbuff(2));
+    end;
+    else do;	/* Get with input */
+      i = 1;			/* skip over leading spaces */
+      do while (tbuff(i) = ' ');
+        i = i + 1;
+      end;
+      begin$buffer = .tbuff(1);	/* note beginning of input */
+      buf$length = tbuff(0);	/* note length of input */
+      buf$ptr = .tbuff(i);	/* set up for scanner */
+      index = 0;
+      delimiter = 1;
+      call opt$scanner(.options(0),.options$offset(0),.index);
+      if (index=10) or (index=11) or (index=14) then do;	/* AUX */
+        call opt$scanner(.options(0),.options$offset(0),.index);
+        if index = 1 then	/* INPUT */
+          call opt$scanner(.options(0),.options$offset(0),.index);
+        if index = 2 then	/* FROM */
+          call opt$scanner(.options(0),.options$offset(0),.index);
+        if index = 3 then do;	/* FILE */
+          getpb.input$type=aux$type;
+          call process$file(buf$ptr);
+        end;
+        else do;
+          if (index=10) or (index=11) or (index=14) then	/* AUX */
+            call kill$rsx;
+          else
+            call error(3);
+        end;
+      end;
+      else do;	/* not AUX */
+        if index = 12 then	/* END  */
+          call end$rsx; 
+        if (index=8) or (index=9) or (index=13) then do;	/* CONSOLE */
+          if delimiter = 9 then
+            call kill$rsx;
+          else
+            call opt$scanner(.options(0),.options$offset(0),.index);
+        end;
+        if index = 1 then	/* INPUT */
+          call opt$scanner(.options(0),.options$offset(0),.index);
+        if index = 2 then	/* FROM */
+          call opt$scanner(.options(0),.options$offset(0),.index);
+        if index = 3 then	/* FILE */
+          call process$file(buf$ptr);
+        if (index=8) or (index=9) or (index=13) then	/* CONIN:, CONSOLE */
+          call kill$rsx;
+        else
+          call error(3);
+      end;
+    end;
+  end;
+end get;