Upload

Digital Research

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/DMP86.PLI

@@ -0,0 +1,238 @@
+dmp86:
+	proc options(main);
+	/* dump 8086 relocatable object file */
+	%replace
+		true    by '1'b,
+		false   by '0'b;
+		/*
+		80h	THEADR	T-module header
+		82h	LHEADR	L-module header
+		84h	PEDATA	Physical Enumerated Data
+		86h	PIDATA	Physical Iterated Data
+		88h	HEX-88
+		8ah	MODEND	Module end
+		8ch	HEX-8C
+		8eh	HEX-8E
+		90h	HEX-90
+		92h	HEX-92
+		94h	HEX-94
+		98h	HEX-98
+		9ah	HEX-9A
+		9ch	HEX-9C
+		*/
+
+	dcl
+		rec_hex(0:14) bit(8) static initial
+		('00'b4,
+		 '80'b4, '82'b4, '84'b4, '86'b4,
+		 '88'b4, '8A'b4, '8C'b4, '8E'b4,
+		 '90'b4, '92'b4, '94'b4, '98'b4,
+		 '9A'b4, '9C'b4),
+		rec_sym(0:14) char(6) static initial
+		('BADREC',
+		 'THEADR','LHEADR','PEDATA','PIDATA',
+		 'HEX-88','MODEND','HEX-8C','HEX-8E',
+		 'HEX-90','HEX-92','HEX-94','HEX-98',
+		 'HEX-9A','HEX-9C');
+
+	dcl
+		module file;
+	dcl
+		buffer (0:127) fixed(7),
+		b_inx fixed(15);
+	dcl
+		line char(254) var;
+	dcl
+		b bit(8), c char(1),
+		i fixed,
+		mod_eof   bit,
+		check_sum fixed(7),
+		rec_type  fixed(7),
+		rec_inx   fixed(7),
+		rec_len   fixed(15);
+
+	on undefinedfile(module)
+		begin;
+		put skip list('Missing Input File');
+		stop;
+		end;
+	open file(module) keyed title('$1.$1') env(f(128),b(4096));
+	on endfile(module)
+		begin;
+		put skip list('Premature EOF');
+		stop;
+		end;
+	b_inx = hbound(buffer,1) + 1;
+	mod_eof = false;
+		do while (^mod_eof);
+		/* get next record */
+		check_sum = 0;
+		rec_len = 32767;
+		rec_type = lod_byte();
+		rec_len = lod_word();
+
+		i = match_rec();
+		put edit(unspec(rec_type),rec_sym(i))
+			(skip,b4(2),x(2),a);
+
+		go to case(i);
+		case(0):  /* BADREC */
+			go to clear_rec;
+
+		case(1):  /* THEADR */
+			line = ' T-Module Name ' || lod_sym();
+			go to put_line;
+
+		case(2):  /* LHEADR */
+			line = ' L-Module Name ' || lod_sym();
+			go to put_line;
+
+		case(3):  /* PEDATA */
+			go to data_rec;
+
+		case(4):  /* PIDATA */
+			go to data_rec;
+
+		case(5):  /* HEX-88 */
+			go to clear_rec;
+
+		case(6):  /* MODEND */
+			mod_eof = true;
+			go to clear_rec;
+
+		case(7):  /* HEX-8C */
+			go to clear_rec;
+
+		case(8):  /* HEX-8E */
+			go to clear_rec;
+
+		case(9):  /* HEX-90 */
+			go to clear_rec;
+
+		case(10): /* HEX-92 */
+			go to clear_rec;
+
+		case(11): /* HEX-94 */
+			go to clear_rec;
+
+		case(12): /* HEX-98 */
+			go to clear_rec;
+
+		case(13): /* HEX-9A */
+			go to clear_rec;
+
+		case(14): /* HEX-9C */
+			go to clear_rec;
+
+		data_rec:
+			put edit(' Frame',lod_addr(),' Offset',gnb())
+				(a,b4(5),a,b4(3));
+		go to clear_rec;
+
+		put_line:
+			put list(line);
+
+		clear_rec:
+			do while (rec_len > 1);
+			put edit('    ') (skip,a);
+			line = '';
+				do rec_type = 1 to 16 while(rec_len > 1);
+				b = lod_bit8();
+				put edit (b) (x(1),b4);
+				if b < '80'b4 & b >= '20'b4 then
+					unspec(c) = b;
+				else
+					c = '.';
+				line = line || c;
+				end;
+			put edit(line) (x(1),a);
+			end;
+			/* read the checksum information */
+			rec_type = lod_byte();
+			if check_sum ^= 0 then
+				put skip list('** Check Sum Error **');
+		end;
+	stop;
+
+	match_rec:
+		proc returns(fixed);
+		dcl
+			i fixed;
+			do i = 1 to hbound(rec_hex,1);
+			if rec_hex(i) = unspec(rec_type) then
+				return (i);
+			end;
+		return (0);
+		end match_rec;
+
+	lod_sym:
+		proc returns(char(254) var);
+		dcl
+			(i,len) fixed(7),
+			x char(254) var;
+		x = '';
+		len = lod_byte();
+		if len < 0 then
+			return ('** Bad Symbol **');
+			do i = 1 to len;
+			x = x || lod_char();
+			end;
+		return(x);
+		end lod_sym;
+
+	lod_char:
+		proc returns(char(1));
+		dcl x char(1);
+		unspec(x) = lod_bit8();
+		return (x);
+		end lod_char;
+
+	lod_byte:
+		proc returns(fixed(7));
+		return (gnf());
+		end lod_byte;
+
+	lod_bit8:
+		proc returns (bit(8));
+		return (gnb());
+		end lod_bit8;
+
+	lod_word:
+		proc returns (fixed(15));
+		dcl x fixed(15);
+		unspec(x) = lod_addr();
+		return (x);
+		end lod_word;
+
+	lod_addr:
+		proc returns(bit(16));
+		dcl x bit(8);
+		x = gnb();
+		return (gnb() || x);
+		end lod_addr;
+
+	gnb:
+		proc returns(bit(8));
+		dcl x fixed(7);
+		x = gnf();
+		return (unspec(x));
+		end gnb;
+
+	gnf:
+		proc returns(fixed(7));
+		dcl x fixed(7);
+		if b_inx > hbound(buffer,1) then
+			do;
+			read file(module) into(buffer);
+			b_inx = 0;
+			end;
+		x = buffer(b_inx);
+		check_sum = check_sum + x;
+		b_inx = b_inx + 1;
+		rec_len = rec_len - 1;
+		if rec_len = -1 then
+			put skip list('** Read Past EOR **');
+		return (x);
+		end gnf;
+	end dmp86;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/LISP.PLI

@@ -0,0 +1,685 @@
+lisp:
+	proc options(main,stack(4096));
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+	%replace
+		true   by '1'b,
+		false  by '0'b;
+	%replace
+		expr   by  0,
+		fexpr  by  1,
+		subr   by  2,
+		fsubr  by  3,
+		apval  by  4,
+		atomic by  5,
+		cell   by  6;
+
+	dcl
+		m_exp entry returns (ptr);
+
+	dcl
+		define_ptr  ptr external,
+		label_ptr   ptr external,
+		lambda_ptr  ptr external,
+		cond_ptr    ptr external,
+		quote_ptr   ptr external,
+		nil_ptr     ptr external,
+		true_ptr    ptr external;
+
+	dcl
+		totwds entry returns (fixed(15)),
+		maxwds entry returns (fixed(15)),
+		allwds entry (fixed(15)) returns (ptr),
+		scan entry;
+
+	dcl
+		sysprint file,
+		f_stack(8) file variable external,
+		f_top fixed external,
+		new_file bit(1),
+		new_name char(16) var;
+
+	dcl
+		(lib1, lib2, lib3, lib4, lib5, lib6, lib7, lib8) file;
+
+	dcl
+		accum char(128) var external,
+		hash_table (0:127) ptr external
+			init((128)null),
+		hash_code fixed(7) external;
+
+	dcl
+		1 node based,
+		  2 type fixed(7),
+		  2 carf  ptr,
+		  2 cdrf  ptr;
+	%replace
+		extra_bytes by 6;
+
+	dcl
+		1 atomic_sym based,
+		  2 form fixed(7),
+		  2 coll ptr,
+		  2 p_list ptr,
+		  2 symbol char(128) var;
+
+	dcl
+		trace fixed static external initial(0);
+
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+	allbytes:
+		proc (n) returns (ptr);
+		dcl
+			n fixed;
+		return (allwds(divide(n+1,2,15)));
+		end allbytes;
+
+	compute_hash:
+		proc external;
+		dcl
+			c char(1),
+			i fixed;
+		hash_code = 0;
+			do i = 1 to length(accum);
+			c = substr(accum,i,1);
+			hash_code = hash_code + rank(c);
+			end;
+		if hash_code < 0 then
+			hash_code = abs(hash_code);
+		end compute_hash;
+
+	chars:
+		proc (p) returns (char(128) var);
+		dcl
+			p ptr,
+			c char(1),
+			i fixed;
+			do i = 1 to length(p->symbol);
+			c = substr(p->symbol,i,1);
+			if rank (c) < rank (' ') |
+			   rank (c) > rank ('_') then
+				return ('?-symbol');
+			end;
+		return (p->symbol);
+		end chars;
+
+	lookup:
+		proc returns(ptr) external;
+		dcl
+			p ptr;
+			do p = hash_table(hash_code)
+				repeat(p->coll) while(p~=null);
+			if accum = chars(p) then
+				return (p);
+			end;
+		return (null);
+		end lookup;
+
+	enter:
+		proc returns(ptr) external;
+		dcl
+			i fixed,
+			p ptr;
+		p = allbytes(length(accum)+extra_bytes);
+		p->form = atomic;
+		p->coll = hash_table(hash_code);
+		p->p_list = nil_ptr;
+		p->symbol = accum;
+		hash_table(hash_code) = p;
+		return (p);
+		end enter;
+
+	/*****************************************************
+	*                                                    *
+	*               Elementary Functions                 *
+	*                                                    *
+	*****************************************************/
+	cons:
+		proc (p,q) returns(ptr) external;
+		dcl
+			(p,q,r) ptr;
+		allocate node set (r);
+		r->type = cell;
+		r->carf = p;
+		r->cdrf = q;
+		return (r);
+		end cons;
+
+	car:
+		proc (p) returns (ptr);
+		dcl
+			p ptr;
+		return (p->carf);
+		end car;
+
+	cdr:
+		proc (p) returns (ptr);
+		dcl
+			p ptr;
+		return (p->cdrf);
+		end cdr;
+
+	eq:
+		proc (p,q) returns (bit(1));
+		dcl
+			(p,q) ptr;
+		return (p = q);
+		end eq;
+
+	atom:
+		proc(p) returns(bit(1));
+		dcl
+			p ptr;
+		return (p->type <= atomic);
+		end atom;
+
+	equal:
+		proc(x,y) returns (bit(1)) recursive;
+		dcl
+			(x,y) ptr;
+		if atom(x) then
+			do;
+			if atom(y) then
+				return(eq(x,y));
+			return (false);
+			end;
+		if equal(car(x),car(y)) then
+			return (equal(cdr(x),cdr(y)));
+		return (false);
+		end equal;
+
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+	cadr:
+		proc (p) returns (ptr);
+		dcl
+			p ptr;
+		return (p->cdrf->carf);
+		end cadr;
+
+	caddr:
+		proc (p) returns (ptr);
+		dcl
+			p ptr;
+		return (p->cdrf->cdrf->carf);
+		end caddr;
+
+	caar:
+		proc (p) returns (ptr);
+		dcl
+			p ptr;
+		return (p->carf->carf);
+		end caar;
+
+	cadar:
+		proc (p) returns (ptr);
+		dcl
+			p ptr;
+		return (p->carf->cdrf->carf);
+		end cadar;
+
+	replaca:
+		proc (p,q);
+		dcl
+			(p,q) ptr;
+		p->carf = q;
+		end replaca;
+
+	replacd:
+		proc (p,q) external;
+		dcl
+			(p,q) ptr;
+		p->cdrf = q;
+		end replacd;
+
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+
+	deflist:
+		proc(p) returns(ptr) recursive;
+		dcl
+			(p,q,r) ptr;
+		q = car(p);
+		if atom(q) then
+			do;
+			r = cons(label_ptr,cons(q,cdr(p)));
+			call replacd(q,r);
+			q->type = expr;
+			end;
+		else
+			call error('Not Atomic Name',q);
+		return (q);
+		end deflist;
+
+	define:
+		proc(p) returns(ptr) recursive;
+		dcl
+			p ptr;
+		if p = nil_ptr then
+			return (nil_ptr);
+		return (cons(deflist(car(p)),define(cdr(p))));
+		end define;
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+	dcl
+		i fixed,
+		name char(128) var;
+
+	error:
+		proc(c,x);
+		dcl
+			c char(15) var,
+			x ptr;
+		put skip list('Error:',c);
+		call display(x);
+		go to error_exit;
+		end error;
+
+	evalquote:
+		proc (fn,x) returns(ptr);
+		dcl
+			(fn,x) ptr;
+		return(apply(fn,x,nil_ptr));
+		end evalquote;
+
+	apply:
+		proc ((fn),(x),(a)) returns(ptr) recursive;
+		dcl
+			(fn,x,a) ptr;
+		if atom(fn) then
+			if fn->type = expr then
+				fn = cdr(fn);
+		if trace > 0 then
+			do;
+			put skip list('Apply:');
+			call display(fn);
+			call display(x);
+			call display(a);
+			end;
+		if atom(fn) then
+			do;
+			name = chars(fn);
+			/* check for c....r */
+			if length(name) >= 3 then
+			if substr(name,1,1) = 'C' then
+			if substr(name,length(name),1) = 'R' then
+			if verify(substr(name,2,length(name)-2),
+				'AD') = 0 then
+				do;
+				if x = nil_ptr then
+					return(nil_ptr);
+				x = car(x);
+					do i = length(name)-1 to 2
+						by -1 while(x~=nil_ptr);
+					if substr(name,i,1) = 'A' then
+						x = car(x);
+					else
+						x = cdr(x);
+					end;
+				return (x);
+				end;
+			if name = 'CONS' then
+				return (cons(car(x),cadr(x)));
+			if name = 'EQ' then
+			if eq(car(x),cadr(x)) then
+				return(true_ptr);
+			else
+				return(nil_ptr);
+			if name = 'ATOM' then
+			if atom(car(x)) then
+				return(true_ptr);
+			else
+				return(nil_ptr);
+			if name = 'DEFINE' then
+				return (define(car(x)));
+			if name = 'LIB' then
+				do;
+				new_file = true;
+				new_name = chars(car(x));
+				return(nil_ptr);
+				end;
+			if name = 'TRACE' then
+				do;
+				trace = chars(car(x));
+				return (nil_ptr);
+				end;
+			else
+				return(apply(eval(fn,a),x,a));
+			end;
+		if atom(car(fn)) then
+			do;
+			name = chars(car(fn));
+			if name = 'LAMBDA' then
+				return(eval(caddr(fn),
+					pairlis(cadr(fn),x,a)));
+			if name = 'LABEL' then
+				return(apply(caddr(fn),x,
+					cons(cons(cadr(fn),caddr(fn)),a)));
+			end;
+		call error('Undefined',fn);
+		end apply;
+
+	eval:
+		proc(e,a) returns (ptr) recursive;
+		dcl
+			(e,a) ptr;
+		if trace > 0 then
+			do;
+			put skip list('Eval:');
+			call display(e);
+			call display(a);
+			end;
+		if atom(e) then
+			do;
+			if e = true_ptr then
+				return (true_ptr);
+			if e = nil_ptr then
+				return (nil_ptr);
+			return (cdr(assoc(e,a)));
+			end;
+		if atom(car(e)) then
+			do;
+			name = chars(car(e));
+			if name = 'quote' then
+				return (cadr(e));
+			if name = 'cond' then
+				return (evcon(cdr(e),a));
+			return (apply(car(e),evlis(cdr(e),a),a));
+			end;
+		return (apply(car(e),evlis(cdr(e),a),a));
+		end eval;
+
+	evcon:
+		proc(c,a) returns (ptr) recursive;
+		dcl
+			(c,a) ptr;
+		if eval(caar(c),a) = true_ptr then
+			return (eval(cadar(c),a));
+		return (evcon(cdr(c),a));
+		end evcon;
+
+	evlis:
+		proc (m,a) returns (ptr) recursive;
+		dcl
+			(m,a) ptr;
+		if m = nil_ptr then
+			return (nil_ptr);
+		return (cons(eval(car(m),a),evlis(cdr(m),a)));
+		end evlis;
+
+	pairlis:
+		proc(x,y,a) returns (ptr) recursive;
+		dcl
+			(x,y,a) ptr;
+		if x = nil_ptr then
+			return (a);
+		if y = nil_ptr then
+			call error('Argument Count',x);
+		return (cons(cons(car(x),car(y)),
+				pairlis(cdr(x),cdr(y),a)));
+		end pairlis;
+
+	assoc:
+		proc(x,a) returns (ptr) recursive;
+		dcl
+			(x,a) ptr;
+		if a = nil_ptr then
+			call error('No Value',x);
+		if trace >= 2 then
+			do;
+			put skip list('assoc:');
+			call display(a);
+			call display(x);
+			end;
+		if equal(caar(a),x) then
+			return (car(a));
+		return (assoc(x,cdr(a)));
+		end assoc;
+	/*****************************************************
+	*                                                    *
+	*              List Construction Routines            *
+	*                                                    *
+	*****************************************************/
+	item:
+		proc returns (ptr);
+		dcl
+			p ptr;
+		if accum = 'NIL' then
+			p = nil_ptr;
+		else
+			do;
+			call compute_hash();
+			p = lookup();
+			if p = null then
+				p = enter();
+			end;
+		call scan();
+		return (p);
+		end item;
+
+	tail:
+		proc returns(ptr) recursive;
+		dcl
+			p ptr;
+		if accum = ')' then
+			do;
+			call scan();
+			return (nil_ptr);
+			end;
+		p = cons(list(),nil_ptr);
+		if accum = '.' then
+			do;
+			call scan();
+			call replacd(p,list());
+			if accum = ')' then
+				call scan();
+			else
+				put skip list('Balance Error');
+			end;
+		else
+			call replacd(p,tail());
+		return (p);
+		end tail;
+
+	list:
+		proc returns(ptr) recursive external;
+		if accum = '(' then
+			do;
+			call scan();
+			return (tail());
+			end;
+		return (item());
+		end list;
+
+	/*****************************************************
+	*                                                    *
+	*              List Display Routines                 *
+	*                                                    *
+	*****************************************************/
+	d_tail:
+		proc (p) recursive;
+		dcl
+			p ptr;
+		if p = nil_ptr then
+			return;
+		if atom(p) then
+			do;
+			put list('.');
+			put list(chars(p));
+			end;
+		else
+			do;
+			call d_list(car(p));
+			call d_tail(cdr(p));
+			end;
+		end d_tail;
+
+	d_list:
+		proc (p) recursive;
+		dcl
+			p ptr;
+		if atom(p) then
+			put list(chars(p));
+		else
+			do;
+			put list('(');
+			call d_tail(p);
+			put list(')');
+			end;
+		end d_list;
+
+	display:
+		proc (p);
+		dcl
+			p ptr;
+		put skip;
+			call d_list(p);
+		end display;
+
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+
+	release:
+		proc (p) recursive;
+		dcl
+			p ptr;
+		if p = nil_ptr then
+			return;
+		if atom(p) then
+			return;
+		call release(car(p));
+		call release(cdr(p));
+		free p->node;
+		end release;
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+	init:
+		proc;
+		accum = 'DEFINE';
+		call compute_hash();
+		define_ptr = enter();
+		accum = 'LABEL';
+		call compute_hash();
+		label_ptr = enter();
+		accum = 'LAMBDA';
+		call compute_hash();
+		lambda_ptr = enter();
+		accum = 'COND';
+		call compute_hash();
+		cond_ptr = enter();
+		accum = 'QUOTE';
+		call compute_hash();
+		quote_ptr = enter();
+		accum = 'T';
+		call compute_hash();
+		true_ptr = enter();
+		accum = 'LABEL';
+		call compute_hash();
+		label_ptr = enter();
+		accum = 'NIL';
+		call compute_hash();
+		nil_ptr = enter();
+		end init;
+
+	/*****************************************************
+	*                                                    *
+	*                                                    *
+	*****************************************************/
+
+	dcl
+		(fn, x, e) ptr,
+		prompt char(1) var;
+	call init();
+	fn = nil_ptr;
+	x  = nil_ptr;
+	f_stack(1) = lib1;
+	f_stack(2) = lib2;
+	f_stack(3) = lib3;
+	f_stack(4) = lib4;
+	f_stack(5) = lib5;
+	f_stack(6) = lib6;
+	f_stack(7) = lib7;
+	f_stack(8) = lib8;
+	f_top = 1;
+	open file(sysprint) stream output linesize(79)
+		print pagesize(0) title('$con');
+	open file(lib1) stream title('$con');
+	on endfile(lib1)
+		stop;
+	error_exit:
+		do while(true);
+		/*
+		call release(fn);
+		call release(x);
+		*/
+		prompt = '';
+		if f_top = 1 then
+			prompt = '>';
+		put edit (totwds(),'/',maxwds(),' words',prompt)
+			(skip,2(f(5),a),skip,a);
+		call scan();
+		/*
+		fn = list();
+			do while (accum = ')');
+			call scan();
+			end;
+		x  = list();
+			do while (accum ~= ';');
+			call scan();
+			end;
+		*/
+		fn = m_exp();
+		if fn ^= nil_ptr then
+			do;
+			x  = cdr(fn);
+			fn = car(fn);
+			put list('Evalquote:');
+			call display(fn);
+			call display(x);
+			e = evalquote(fn,x);
+			put skip list('Value is:');
+			call display(e);
+			end;
+		if new_file then
+			do;
+			new_file = false;
+			f_top = f_top + 1;
+			if f_top > hbound(f_stack,1) then
+				do;
+				put skip list('Readfile Stack Overflow');
+				f_top = 1;
+				go to error_exit;
+				end;
+			on undefinedfile(f_stack(f_top))
+				begin;
+				put skip list('No File:',new_name);
+				f_top = 1;
+				go to error_exit;
+				end;
+			open file(f_stack(f_top)) stream title(new_name);
+			revert undefinedfile(f_stack(f_top));
+			on endfile(f_stack(f_top))
+				begin;
+				close file(f_stack(f_top));
+				f_top = f_top - 1;
+				go to error_exit;
+				end;
+			end;
+		end;
+	end lisp;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/MEXP.PLI

@@ -0,0 +1,237 @@
+m_exp:
+	proc returns (ptr);
+	%replace
+		true  by '1'b,
+		false by '0'b;
+
+	dcl
+		lower char(26) static initial
+		('abcdefghijklmnopqrstuvwxyz'),
+		upper char(26) static initial
+		('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
+
+	dcl
+		true_ptr   ptr external,
+		define_ptr ptr external,
+		nil_ptr    ptr external,
+		label_ptr  ptr external,
+		lambda_ptr ptr external,
+		cond_ptr   ptr external,
+		quote_ptr  ptr external;
+
+	dcl
+		accum char(128) var external,
+		scan entry,
+		compute_hash entry,
+		lookup returns(ptr),
+		enter returns(ptr),
+		cons entry(ptr,ptr) returns(ptr),
+		replacd entry(ptr,ptr) returns(ptr),
+		list entry returns(ptr);
+
+	dcl
+		m ptr;
+
+	syntax:
+		proc(n);
+		dcl
+			n fixed;
+		put edit(n,' Syntax Error at ',accum)
+			(skip,f(3),2a);
+			do while (accum ^= ';');
+			call scan();
+			end;
+		go to error_exit;
+		end syntax;
+
+	var:
+		proc returns(ptr);
+		dcl
+			p ptr;
+		if accum = 'T' then
+			return (true_ptr);
+		if accum = 'F' | accum = 'NIL' then
+			return (nil_ptr);
+		if index(lower,substr(accum,1,1)) = 0 then
+			call syntax(10);
+		accum = translate(accum,upper,lower);
+		call compute_hash();
+		p = lookup();
+		if p = null then
+			p = enter();
+		call scan();
+		return (p);
+		end var;
+
+	v_tail:
+		proc returns (ptr) recursive;
+		if accum = ']' then
+			do;
+			call scan();
+			return (nil_ptr);
+			end;
+		if accum = ';' then
+			do;
+			call scan();
+			return (v_list());
+			end;
+		call syntax(20);
+		end v_tail;
+
+	v_list:
+		proc returns (ptr) recursive;
+		return (cons(var(),v_tail()));
+		end v_list;
+
+	func:
+		proc returns(ptr) recursive;
+		dcl
+			(v, e, f) ptr;
+		if accum = 'label' then
+			do;
+			call scan();
+			if accum ^= '[' then
+				call syntax(30);
+			call scan();
+			v = var();
+			if accum ^= ';' then
+				call syntax(40);
+			call scan();
+			f = func();
+			if accum ^= ']' then
+				call syntax(42);
+			call scan();
+			return (cons(label_ptr,
+				cons(v,cons(f,nil_ptr))));
+			end;
+		if accum = 'lambda' then
+			do;
+			call scan();
+			if accum ^= '[' then
+				call syntax(50);
+			call scan();
+			if accum ^= '[' then
+				call syntax(60);
+			call scan();
+			if accum = ']' then
+				do;
+				call scan();
+				v = nil_ptr;
+				end;
+			else
+				v = v_list();
+			if accum ^= ';' then
+				call syntax(70);
+			call scan();
+			e = exp();
+			if accum ^= ']' then
+				call syntax(80);
+			call scan();
+			return (cons(lambda_ptr,
+				cons(v,cons(e,nil_ptr))));
+			end;
+		return(var());
+		end func;
+
+	c_tail:
+		proc returns(ptr) recursive;
+		if accum = ']' then
+			do;
+			call scan();
+			return (nil_ptr);
+			end;
+		if accum = ';' then
+			do;
+			call scan();
+			return (c_list());
+			end;
+		call syntax(90);
+		end c_tail;
+
+	c_list:
+		proc returns(ptr) recursive;
+		dcl
+			p ptr;
+		p = exp();
+		if accum ^= '-' then
+			call syntax(100);
+		call scan();
+		if accum ^= '>' then
+			call syntax(110);
+		call scan();
+		return (cons(cons(p,cons(exp(),nil_ptr)),c_tail()));
+		end c_list;
+
+	e_tail:
+		proc returns (ptr) recursive;
+		if accum = ']' then
+			do;
+			call scan();
+			return (nil_ptr);
+			end;
+		if accum = ';' then
+			do;
+			call scan();
+			return (e_list());
+			end;
+		call syntax(120);
+		end e_tail;
+
+	e_list:
+		proc returns (ptr) recursive;
+		return (cons(exp(),e_tail()));
+		end e_list;
+
+	exp:
+		proc returns(ptr) recursive;
+		dcl
+			(f, el, ef) ptr;
+		if accum = '"' then
+			do;
+			call scan();
+			el = list();
+			if accum ^= '"' then
+				call syntax(122);
+			call scan();
+			return (cons(quote_ptr,cons(el,nil_ptr)));
+			end;
+		if accum = '[' then
+			do;
+			call scan();
+			return (cons(cond_ptr,c_list()));
+			end;
+		f = func();
+		if accum ^= '[' then
+			/* (lambda or label) */
+			return(f);
+		call scan();
+		if accum = ']' then
+			do;
+			call scan();
+			el = nil_ptr;
+			end;
+		else
+			el = e_list();
+		if accum ^= '=' then
+			return (cons(f,el));
+		call scan();
+		ef = exp();
+		/* (define (( (f (lambda el ef) )   )) ) */
+		el = cons(lambda_ptr,cons(el,cons(ef,nil_ptr)));
+		el = cons(el,nil_ptr);
+		f = cons(cons(cons(f,el),nil_ptr),nil_ptr);
+		return (cons(define_ptr,cons(f,nil_ptr)));
+		end exp;
+
+	m = exp();
+		do while (true);
+		if accum = ';' then
+			return (m);
+		if accum ^= ']' then
+			call syntax(130);
+		call scan();
+		end;
+	error_exit:
+	return (nil_ptr);
+	end m_exp;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/OLDMEXP.PLI

@@ -0,0 +1,276 @@
+m_exp:
+	proc returns (ptr);
+	%replace
+		true  by '1'b,
+		false by '0'b;
+
+	dcl
+		lower char(26) static initial
+		('abcdefghijklmnopqrstuvwxyz');
+
+	dcl
+		accum char(128) var external,
+		scan entry(fixed);
+
+	dcl
+		m ptr;
+
+	syntax:
+		proc(n);
+		dcl
+			n fixed;
+		put edit(n,' Syntax Error at ',accum)
+			(skip,f(3),2a);
+			do while (accum ^= ';');
+			call scan(10);
+			end;
+		go to error_exit;
+		end syntax;
+
+	var:
+		proc returns(ptr);
+		if index(lower,substr(accum,1,1)) = 0 then
+			call syntax(10);
+		else
+			do;
+			put skip list('var',accum);
+			call scan(20);
+			end;
+		return (null);
+		end var;
+
+	v_tail:
+		proc returns (ptr) recursive;
+		if accum = ']' then
+			do;
+			call scan(30);
+			return (null);
+			end;
+		if accum = ';' then
+			do;
+			call scan(40);
+			return (v_list());
+			end;
+		call syntax(20);
+		return (null);
+		end v_tail;
+
+	v_list:
+		proc returns (ptr) recursive;
+		dcl
+			(v, vt) ptr;
+		v = var();
+		vt = v_tail();
+		/* cons (v,vt) */
+		return (null);
+		end v_list;
+
+	func:
+		proc returns(ptr) recursive;
+		dcl
+			(v, e, f) ptr;
+		if accum = 'label' then
+			do;
+			call scan(50);
+			if accum ^= '[' then
+				call syntax(30);
+			else
+				do;
+				call scan(60);
+				v = var();
+				if accum ^= ';' then
+					call syntax(40);
+				else
+					do;
+					call scan(70);
+					f = func();
+					if accum ^= ']' then
+						call syntax(42);
+					else
+						do;
+						call scan(72);
+						put skip list('(LABEL v f)');
+						end;
+					return (null);
+					end;
+				end;
+			end;
+		else
+		if accum = 'lambda' then
+			do;
+			call scan(80);
+			if accum ^= '[' then
+				call syntax(50);
+			else
+				do;
+				call scan(90);
+				if accum ^= '[' then
+					call syntax(60);
+				else
+					do;
+					call scan(100);
+					if accum = ']' then
+						do;
+						call scan(110);
+						v = null;
+						end;
+					else
+					v = v_list();
+					put skip list('(v1 ... vn)');
+					if accum ^= ';' then
+						call syntax(70);
+					else
+						do;
+						call scan(120);
+						e = exp();
+						if accum ^= ']' then
+							call syntax(80);
+						else
+							do;
+							call scan(130);
+							put skip list ('(LAMBDA (V1 ... Vn) e)');
+							return(null);
+							end;
+						end;
+					end;
+				end;
+			end;
+		else
+			do;
+			v = var();
+			put skip list('VAR');
+			return (v);
+			end;
+		return (null);
+		end func;
+
+	q_tail:
+		proc returns(ptr);
+		put skip;
+			do while (accum ^= '"');
+			put list(accum);
+			call scan(140);
+			end;
+		call scan(142);
+		return (null);
+		end q_tail;
+
+	c_tail:
+		proc returns(ptr) recursive;
+		if accum = ']' then
+			do;
+			call scan(150);
+			return (null);
+			end;
+		if accum = ';' then
+			do;
+			call scan(160);
+			return (c_list());
+			end;
+		call syntax(90);
+		return (null);
+		end c_tail;
+
+	c_list:
+		proc returns(ptr) recursive;
+		dcl
+			(p, q, r) ptr;
+		p = exp();
+		if accum ^= '-' then
+			call syntax(100);
+		else
+			do;
+			call scan(170);
+			if accum ^= '>' then
+				call syntax(110);
+			else
+				do;
+				call scan(180);
+				q = exp();
+				put skip list('(P Q)');
+				/* cons(cons(p,q),c_list)) */
+				r = c_tail();
+				return (null);
+				end;
+			end;
+		return (null);
+		end c_list;
+
+	e_tail:
+		proc returns (ptr) recursive;
+		if accum = ']' then
+			do;
+			call scan(190);
+			return (null);
+			end;
+		if accum = ';' then
+			do;
+			call scan(200);
+			return (e_list());
+			end;
+		call syntax(120);
+		return (null);
+		end e_tail;
+
+	e_list:
+		proc returns (ptr) recursive;
+		dcl
+			(e, et) ptr;
+		e = exp();
+		et = e_tail();
+		/* cons (e,et) */
+		return (null);
+		end e_list;
+
+	exp:
+		proc returns(ptr) recursive;
+		dcl
+			(f, e) ptr;
+		if accum = '"' then
+			do;
+			call scan(210);
+			e = q_tail();
+			put skip list('(QUOTE e)');
+			return (null);
+			end;
+		else
+		if accum = '[' then
+			do;
+			call scan(220);
+			e = c_list();
+			put skip list('(COND e)');
+			return (null);
+			end;
+		else
+			do;
+			f = func();
+			if accum ^= '[' then
+				do;
+				/* (lambda or label) */
+				return (null);
+				end;
+			call scan(230);
+			if accum = ']' then
+				do;
+				call scan(240);
+				e = null;
+				end;
+			else
+				e = e_list();
+			put skip list('(FUNC e)');
+			return (null);
+			end;
+		end exp;
+
+	call scan(250);
+	m = exp();
+		do while (accum ^= ';');
+		call scan(260);
+		if accum ^= ']' then
+			call syntax(130);
+		end;
+	return (m);
+	error_exit:
+	return (null);
+	end m_exp;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/SC.PLI

@@ -0,0 +1,62 @@
+scan:
+	proc(n);
+	%replace
+		true  by '1'b,
+		false by '0'b;
+	dcl
+		n fixed,
+		accum char (128) var external,
+		line  char (128) var static init('');
+	dcl
+		c char(1),
+		i fixed;
+
+	tracer:
+		proc;
+		put edit(n,' scan: ',accum) (skip,f(3),2a);
+		end;
+
+		do while(true);
+		if length(line) = 0 then
+			get edit(line) (a);
+		else
+			line = substr(line,length(accum)+1);
+		i = verify(line,' ');
+		if i = 0 then
+			line = '';
+		else
+			do;
+			line = substr(line,i);
+			accum = substr(line,1,1);
+			if index('[]->;().,"',accum) ~= 0 then
+				do;
+				call tracer();
+				return;
+				end;
+				do i = 2 to length(line);
+				c = substr(line,i,1);
+				if index(' []->;().,"',c) ~= 0 then
+					do;
+					accum = substr(line,1,i-1);
+					if c ~= '.' then
+						do;
+						call tracer();
+						return;
+						end;
+					if verify(accum,'0123456789') ~= 0 then
+						do;
+						call tracer();
+						return;
+						end;
+					end;
+				end;
+			accum = line;
+			do;
+			call tracer();
+			return;
+			end;
+			end;
+		end;
+	call tracer();
+	end scan;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/SCAN.PLI

@@ -0,0 +1,44 @@
+scan:
+	proc;
+	%replace
+		true  by '1'b,
+		false by '0'b;
+	dcl
+		f_stack(8) file variable external,
+		f_top fixed external,
+		accum char (128) var external,
+		line  char (128) var static init('');
+	dcl
+		c char(1),
+		i fixed;
+		do while(true);
+		if length(line) = 0 then
+			get file(f_stack(f_top)) edit(line) (a);
+		else
+			line = substr(line,length(accum)+1);
+		i = verify(line,' ');
+		if i = 0 then
+			line = '';
+		else
+			do;
+			line = substr(line,i);
+			accum = substr(line,1,1);
+			if index('[]->;().,"',accum) ~= 0 then
+				return;
+				do i = 2 to length(line);
+				c = substr(line,i,1);
+				if index(' []->;().,',c) ~= 0 then
+					do;
+					accum = substr(line,1,i-1);
+					if c ~= '.' then
+						return;
+					if verify(accum,'0123456789') ~= 0 then
+						return;
+					end;
+				end;
+			accum = line;
+			return;
+			end;
+		end;
+	end scan;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/X.PLI

@@ -0,0 +1,6 @@
+x:
+	proc options(main);
+	put skip list(translate('abc','AB','ab'));
+	put skip list(translate('abc','ab','AB'));
+	end x;
+

MPM OPERATING SYSTEMS/MPM-86/MISC DRI DISKS/09/XLATE.PLI

@@ -0,0 +1,48 @@
+xlate:
+	proc;
+	/* translate an M-expression to S-expression form */
+	if accum = 'label' then
+		do;
+		line = line || '(LABEL';
+		call scan();
+		if accum = '[' then
+			call scan();
+		else
+			call syntax();
+		call x_var();
+		call x_exp();
+		if accum = ']' then
+			call scan();
+		else
+			call syntax();
+		line = line || ')';
+		end;
+	else
+	if accum = 'lambda' then
+		do;
+		line = line || '(LAMBDA ';
+		call scan();
+		if accum = '[' then
+			call scan();
+		else
+			call syntax();
+		call x_formal();
+		call xx();
+		if accum = ']' then
+			call scan();
+		else
+			call syntax();
+		end;
+	else
+		do;
+		line = line ||'(';
+		call x_func();
+		if accum = '[' then
+			call scan();
+		else
+			call syntax();
+			do while (accum ^= ']');
+			call x_arg();
+			end;
+		end;
+