reduce-historical/r30/fap.red

COMMENT The FAP building module;

COMMENT this module needs to IMPORT MATHPR;

%PUT('FAP,'IMPORTS,'(MEVAL COMPLR IO));


COMMENT FASLOUT, used to produce FAP files for
       subsequent fast loading (FISL);

SYMBOLIC$	% This page links Lisp compiler to FASLAP producer;

SYMBOLIC SMACRO PROCEDURE !&PUSH(A,B); B := A . B;

GLOBAL '(DFPRINT!* !*MODULE !*FASLMSG !*ARGNAMES !*ARGCOUNT);

COMMENT !*ARGNAMES enables generation of list of all argument names
	for compiled functions
	!*ARGCOUNT enables generation of just a number showing how 
	many args a function has, but not what they are called;

FLUID '(MSGCHN!* FSLCHN!*
	FILE !*DEFN CFL!* BTIME!*
	FASLOUTFILE USERFORF OFILE PROP BASE IBASE
	XPR DDTSYMS UNDEFSYMS SYM LITERALS NUMBERTABLE 
	ENTRYPOINTS
     ALLATOMS AMBIGSYMS ATOMINDX BFUNCS BINCT CURRENTFNSYMS 
     CURRENTFN DDTSYMP DDTSYMS !*FASLDEBUG FILOC LITCNT 
     LITERALS LITLOC LOC MAINSYMPDL NUMBERTABLE PASS2LIT SYMBOLSP 
     SYMPDL UNDEFSYMS WINP
);

IF NOT GETD 'BEGIN THEN
  <<FLAG('(RDS DEFLIST FLAG FLUID GLOBAL REMPROP REMFLAG UNFLUID
	   DM FASLEND),'EVAL);
    FLAG('(RDS),'IGNORE)>>;

SYMBOLIC PROCEDURE FASLOUT FIL;
% Initiate FSL to file FIL;
  FSLOUTF MKFIL ADDEXTN(CAR FIL,'FAP);

SYMBOLIC PROCEDURE ADDEXTN(U,V);
   %Adds the extension V to the file named U;
   BEGIN SCALAR X,Y;
      X := EXPLODEC U;
      Y := REVERSE X;
   A: IF NULL Y OR CAR Y EQ '!>
	THEN RETURN COMPRESS('!" .
			  NCONC(X,'!. . ACONC(EXPLODEC V,'!")))
       ELSE IF CAR Y EQ '!. THEN TYPERR(U,"fasl file name");
      Y := CDR Y;
      GO TO A
   END;


IF GETD 'BEGIN THEN RLISTAT '(FASLOUT);   %only do it if REDUCE used;

SYMBOLIC PROCEDURE FSLOUT1 X;
   IF ATOM X THEN FSLOUTS X
    ELSE IF CAR X EQ 'DE
     THEN FSLOUT2(CADR X,'EXPR,LIST('LAMBDA,CADDR X,CADDDR X))
    ELSE IF CAR X EQ 'DF
     THEN FSLOUT2(CADR X,'FEXPR,LIST('LAMBDA,CADDR X,CADDDR X))
    ELSE IF CAR X EQ 'DM AND FLAGP('MACRO,'COMPILE)
     THEN FSLOUT2(CADR X,'MACRO,LIST('LAMBDA,CADDR X,CADDDR X))
    ELSE IF CAR X MEMQ '(PUTD PUTC) AND EQCAR(CADR X,'QUOTE)
            AND EQCAR(CADDR X,'QUOTE) AND EQCAR(CADDDR X,'QUOTE)
            AND FLAGP(CADR CADDR X,'COMPILE)
        THEN FSLOUT2(CADADR X,CADAR(X:=CDDR X),CADADR X)
    ELSE IF CAR X EQ 'PROGN THEN FOR EACH Z IN CDR X DO FSLOUT1 Z
    ELSE IF CAR X EQ 'LETFN THEN EVAL X
    ELSE IF CAR X EQ 'PUTC THEN FSLOUTS('PUT . CDR X)
    ELSE FSLOUTS X;


SYMBOLIC PROCEDURE FSLOUT2(NAME,TYPE,EXP);
	IF !*MODULE THEN MODCMP(NAME,TYPE,EXP)
	 ELSE IF NAME MEMQ FUNCNAMES!* AND TYPE MEMQ FTYPES!* THEN NIL
	   %means part of a compilable LET;
	 ELSE FSLOUT3(NAME,TYPE,EXP);

SYMBOLIC PROCEDURE FSLOUT3(NAME,TYPE,EXP);
  BEGIN SCALAR VARLIS; %SCALAR BASE,IBASE;
	IF NOT FLAGP(TYPE,'COMPILE)
	   THEN ERROR(0,LIST("UNCOMPILABLE FUNCTION",
			     NAME,"OF TYPE",TYPE));
	IF TYPE MEMQ '(EXPR FEXPR) AND NOT EQCAR(GETD NAME,TYPE)
	  THEN PUT(NAME,'CFNTYPE,LIST TYPE);	% careful for fwd ref;
	VARLIS := CADR EXP;
	EXP := !&COMPROC(EXP,IF TYPE MEMQ '(EXPR FEXPR) THEN NAME);
	FSLOUTS LIST('LAP,
		 MKQUOTE(LIST('!*ENTRY,NAME,TYPE,LENGTH VARLIS) . EXP));
	IF !*ARGNAMES OR !*ARGCOUNT
	  THEN FSLOUTS LIST('PUT,MKQUOTE NAME,MKQUOTE 'ARGUMENTS!*,
			    IF !*ARGNAMES THEN MKQUOTE LIST VARLIS
			     ELSE LENGTH VARLIS)
  END;

GLOBAL '(!$EOF!$);

SYMBOLIC PROCEDURE FSLOUTF FILE;
     BEGIN SCALAR A,CRFIL,OCRFIL;
	BTIME!* := TIME();
	TERPRI();
	IF GETD 'BEGIN THEN
	  <<PRIN2 "FASLOUT: IN files;  or type in expressions";
	    TERPRI();
	    PRIN2 "When all done, execute FASLEND; ">>
	 ELSE <<PRIN2 "FASLOUT: (DSKIN files) or type in expressions";
		TERPRI();
		PRIN2 "When all done, execute (FASLEND) ">>;
	TERPRI();
	WINP:=NIL;  % Error Flag;
	LOC:=FILOC:=LITLOC:=LITCNT:=BINCT:=NIL;
	ATOMINDX:=NIL; 			% Numeric;
	CURRENTFN:=DDTSYMP:=SYMBOLSP:=NIL; 
	PASS2LIT:=NIL; 	  % Var & flags;
	CURRENTFNSYMS:=SYMPDL:=MAINSYMPDL:=NIL;	  % !&PUSHed on;
	DDTSYMS:=AMBIGSYMS:=UNDEFSYMS:=LITERALS:=NIL;
	CURRENTFN:='FASLOUT;
	WINP:=ERRORSET('(FASL!-START FILE),T,!*BAKGAG);
	   %sets channel;
	FSLCHN!* := WRS MSGCHN!*;
	IF ATOM WINP THEN
	  <<TERPRI();
	    PRIN2 LIST( "FASL aborted, in",CURRENTFN,"after",
		FILOC,'!+,LOC);
	    TERPRI();
	    RETURN WINP>>;
	DFPRINT!* := 'FSLOUT1;
	!*COMP := NIL;  %to avoid recompilation of macros;
	!*DEFN:=T;
	IF GETD 'BEGIN THEN RETURN WINP;
  NDF:	IF NOT (A EQ !$EOF!$) THEN <<WINP:=A; GO LOP>>;
	CRFIL:=NIL;
	IF NULL OCRFIL THEN GO LOP;
	CRFIL:=CAAR OCRFIL;
	RDS CDAR OCRFIL;
	OCRFIL:=CDR OCRFIL;
  LOP:	A:=ERRORSET('(READ),T,!*BAKGAG);
	IF ATOM A THEN GO NDF;
	A:=CAR A;
	IF NOT PAIRP A THEN <<WINP := A; GO LOP>>;
	IF CAR A EQ 'DSKIN THEN
	   <<OCRFIL:=(CRFIL.RDS OPEN(CDR A,'INPUT)).OCRFIL;
	     CRFIL:=CDR A; GO LOP>>;
	IF NOT FLAGP(CAR A,'IGNORE)
	  THEN ERRORSET(LIST('FSLOUT1,MKQUOTE A),T,!*BAKGAG);
	IF FLAGP(CAR A,'EVAL) OR
           CAR A EQ 'SETQ AND
	    (CADDR A MEMQ '(T NIL) OR CONSTANTP CADDR A OR
	     EQCAR(CADDR A,'QUOTE))
	  THEN ERRORSET(A,T,!*BAKGAG);
	IF !*DEFN THEN GO LOP;
	RETURN WINP
   END;

IF NULL GETD 'BEGIN THEN PUTD('FASLOUT,'FEXPR,CDR GETD 'FSLOUTF);

SYMBOLIC PROCEDURE FASLEND;
   BEGIN  %SCALAR BASE,IBASE;
    	WINP:=ERRORSET('(FASL!-CLOSE WINP),T,!*BAKGAG);
	DFPRINT!* := NIL;
	TERPRI();
	!*DEFN:=NIL;
	PRIN2 "Atomindex: ";
	PRIN2 ATOMINDX;
	PRIN2 "   block length: ";
	PRIN2 FILOC; PRIN2 "   time: ";PRIN2 BTIME!*; PRIN2 " ms"; TERPRI();
   END;

FLAG('(FASLEND),'IGNORE);   %To execute in ON DEFN mode, no output;

PUT('FASLEND,'STAT,'ENDSTAT);

SYMBOLIC PROCEDURE FSLOUTS1 X;
	IF NULL X THEN T
	  ELSE IF ATOM X THEN FBF LIST("UnFASL'd:",X)
	  ELSE FASLIFY X;

SYMBOLIC PROCEDURE FSLOUTS U;
   BEGIN
	CURRENTFN:='FSLOUTS;
	MSGCHN!* := WRS FSLCHN!*;
	WINP:=ERRORSET(LIST('FSLOUTS1,MKQUOTE U),T,!*BAKGAG);
	FSLCHN!* := WRS MSGCHN!*;
	WINP:= IF ATOM WINP THEN
	  <<TERPRI();
	    PRINT LIST("FASL aborted, in",CURRENTFN,
			"after",FILOC,'!+,LOC);
	    TERPRI()>>
	  ELSE T;
	RETURN WINP;
   END;


!*FASLDEBUG:=NIL$

GLOBAL '(BNAR BTAR BXAR);


BTAR:=MKVECT 9;
BNAR:=MKVECT 9;
BXAR:=MKVECT 9;


SYMBOLIC PROCEDURE FASL!-START OFILE;
   BEGIN
	BINCT:= 0;
	ATOMINDX:= 0;
	LOC:=FILOC:=LITLOC:= 0;
	NUMBERTABLE:= ALLATOMS:= NIL;
	SYMPDL:= MAINSYMPDL:= CURRENTFNSYMS:= NIL;
	IF ATOM OFILE THEN OFILE:= 'DSK!: . LIST OFILE ELSE
	IF NOT !%DEVP CAR OFILE THEN OFILE:= 'DSK!: . OFILE;
	MSGCHN!* := WRS OPEN(OFILE,'OUTBIN);
	BFBO (-30863143776);	% ASCII /FASLP/;
	BFBO EXAMINE 95;	% Lisp assembly-version #, someday;
   END;

FLUID '(ELIST);

GLOBAL '(FUNCNAMES!*);

SYMBOLIC PROCEDURE FASL!-CLOSE FLG;
   BEGIN
	IF !*MODULE THEN BLKCMP();
	WHILE ELIST DO <<FSLOUT1 CAR ELIST; ELIST := CDR ELIST>>;
	IF FUNCNAMES!* THEN FOR EACH X IN FUNCNAMES!* DO
	   BEGIN SCALAR Y; 
	      IF (Y := GETD X) THEN IF CAR Y MEMQ '(EXPR FEXPR)
		THEN <<FSLOUT3(X,CAR Y,CDR Y);
			REMD X;
			PUT(X,'CFNTYPE,LIST CAR Y)>>
	        ELSE NIL;
		   %presumably function defined in earlier module;
	   END;
    	BTIME!* := TIME()-BTIME!*; 
	MSGCHN!* := WRS FSLCHN!*;
	IF FLG THEN BUFO(15,0,NIL);		% EOF word if no ERR;
	CLOSE WRS MSGCHN!*;
	REMPROPL(ALLATOMS,'ATOMINDX);
	NUMBERTABLE:=ALLATOMS:=NIL;
	SYMPDL:=MAINSYMPDL:=CURRENTFNSYMS:=NIL;
   END;


SYMBOLIC PROCEDURE FASLIFY Y;
   BEGIN
	CURRENTFN:= 'FASLIFY;
	IF ATOM Y THEN NIL	% IGNORE RANDOM ATOMS;
	ELSE IF CAR Y MEMQ '(LAP LAP10) THEN
	  BEGIN
		FASLPASS1 (Y:= FASLPASS0 (NIL . EVAL CADR Y));
		FASLPASS2 Y;
		FILOC:= FILOC+LOC;
	  END
	ELSE IF MUNGEABLE Y THEN <<IF CAR Y EQ 'SETQ 
					THEN CURRENTFN:= CADR Y;
				   COLLECTATOMS Y;
				   BUFO(14,LSH(-1,18),Y)>>
	ELSE IF NOT MEMQ(CAR Y,'(COMMENT QUOTE)) THEN
		FBF LIST("UNFASL'd:",Y)
   END;

SYMBOLIC PROCEDURE MUNGEABLE X;
   NOT (MEMQ(CAR X,'(COMMENT QUOTE)) OR
	CAR X EQ 'EVAL AND EQCAR(CADR X,'QUOTE));


%SYMBOLIC PROCEDURE FASLPASS0 FLAP;	% Convert any MCs else stet;
%   BEGIN SCALAR X,Y,L;
%	X:=FLAP;
%    LP:	IF NULL (Y:=CDR X) THEN RETURN FLAP
%	 ELSE IF ATOM(L:=CAR Y) OR NUMBERP CAR L
%		OR CAR L EQ '!*ENTRY
%		OR CADR L MEMQ '(FEXPR EXPR) THEN NIL
%	 ELSE IF FLAGP(CAR L,'MC) THEN
%		<<RPLACD(X,APPEND(EVAL(CAR L,
%			    FOR EACH J IN CDR L COLLECT MKQUOTE J),
%			          CDR Y)),
%		  GO TO LP>>;
%	X:=CDR X;
%	GO TO LP;
%   END;

SYMBOLIC PROCEDURE FASLPASS0 U; U;   %now done by pass1;

SYMBOLIC PROCEDURE FASLPASS1 Q;		% =((LAP) ... NIL);
   (LAMBDA BASE,IBASE;
     BEGIN SCALAR AMBIGSYMS,N,XPR;
	LOC:=0;
	CURRENTFNSYMS:= LITERALS:= NIL;
	DDTSYMP:= SYMBOLSP:= NIL;
	WHILE CDR Q DO
	   <<IF ATOM (XPR:= CADR Q) THEN 
		<<FASLDEFSYM(XPR,LIST('RELOC,FILOC+LOC));
		  Q := NIL . RPLACD(Q,CDDR Q)>>
 	ELSE IF CAR XPR EQ '!*ENTRY
 	 THEN <<IF GET(CADR XPR,'ENTRY) THEN 
 			FBF LIST("Duplicate entryname:",CADR XPR);
			IF !*COUNTMC THEN
			 RPLACD(CDR Q,
			   APPEND(<<PUT(CAR XPR,'MCCOUNT,
					     ADD1 GET(CAR XPR,'MCCOUNT));
				    COUNTMC CAR XPR>>,CDDR Q));
 			PUT(CADR XPR,'ENTRY,FILOC+LOC)>>
 	ELSE IF CADR XPR MEMQ '(FEXPR EXPR) THEN
 		<<IF GET(CAR XPR,'ENTRY) THEN 
 			FBF LIST("Duplicate entryname:",CAR XPR);
 			PUT(CAR XPR,'ENTRY,FILOC+LOC)>>
%	ELSE IF CAR XPR EQ 'DEFSYM THEN FASLDEFSYM(XPR,NIL)	% EVAL
%	ELSE IF CAR XPR EQ 'DDTSYM THEN
%		     << DDTSYMP:=T;
%			MAPC(CDR XPR,FUNCTION !*DDTSYM)>>
%	ELSE IF CAR XPR EQ 'EVAL THEN MAPC(CDR XPR,FUNCTION EVAL)
%	ELSE IF CAR XPR EQ 'SYMBOLS THEN SYMBOLSP:=T
%	ELSE IF MEMQ(CAR XPR,'(ASCII SIXBIT BLOCK)) THEN
%		LOC:= LOC + BLOBLENGTH XPR;
       ELSE IF FLAGP(CAR XPR,'MC)
	THEN Q := NIL . RPLACD(Q,
	 APPEND(IF !*COUNTMC
		  THEN <<PUT(CAR XPR,'MCCOUNT,ADD1 GET(CAR XPR,'MCCOUNT));
			 COUNTMC CAR XPR>>,
	  APPEND(EVAL(CAR XPR . 
				FOR EACH J IN CDR XPR COLLECT MKQUOTE J),
				CDDR Q)))
	ELSE IF NOT MEMQ(CAR XPR,'(COMMENT ARGS)) THEN
		<<RECLITCOUNT(XPR,T); LOC:=LOC+1>>;
	Q := CDR Q>>;
	LITLOC:= LOC;	% where to assemble literals;
	LITERALS:= REVERSE LITERALS;
     END)
   (8,8);


SYMBOLIC PROCEDURE FASLPASS2 Q;
   (LAMBDA BASE,IBASE,LITCNT;
     BEGIN SCALAR DDTSYMS,AMBIGSYMS,LASTENTRY,ENTRYPOINTS,PASS2LIT,
		  UNDEFSYMS,OLITERALS,XPR;
	OLITERALS:=LITERALS;
	LOC:=0;
	WHILE Q:=CDR Q DO
	     IF ATOM (XPR:=CAR Q) THEN
%		IF SYMBOLSP THEN BUFO(13,0,XPR) ELSE; NIL
 	ELSE IF CAR XPR EQ '!*ENTRY
 	 THEN <<COLLECTATOMS CADR XPR;
		COLLECTATOMS CADDR XPR;
 		!&PUSH(CDR XPR . (FILOC+LOC), ENTRYPOINTS);
% 		IF SYMBOLSP THEN BUFO(13,0,CADR XPR);
 		LASTENTRY:= CADR XPR>>
 	ELSE IF CADR XPR MEMQ '(FEXPR EXPR) THEN
 	      <<COLLECTATOMS CAR XPR;
		COLLECTATOMS CADR XPR;
 		!&PUSH(XPR . (FILOC+LOC), ENTRYPOINTS);
% 		IF SYMBOLSP THEN BUFO(13,0,CAR XPR);
 		LASTENTRY:= CAR XPR>>
%	ELSE IF CAR XPR EQ 'ARGS THEN
%		IF CADR XPR EQ LASTENTRY THEN 
%			PUT(CADR XPR,'ARGSINFO,CADDR XPR)
%		ELSE FBF LIST("ARGS misplaced",XPR)
%	ELSE IF CAR XPR EQ 'SYMBOLS THEN SYMBOLSP:=CADR XPR
%	ELSE IF CAR XPR EQ 'EVAL THEN MAPC(CDR XPR,FUNCTION EVAL)
%	ELSE IF CAR XPR EQ 'DDTSYM THEN
%		MAPC(CDR XPR,FUNCTION(LAMBDA X;
%		  IF NOT MEMQ(X,DDTSYMS) THEN !&PUSH(X,DDTSYMS)));
      ELSE IF FLAGP(CAR XPR,'MC)
	 THEN ERROR(0,"SEE ACH: FASLPASS2 MC TEST TRUE")
%	 THEN APPEND(IF !*COUNTMC
%		  THEN <<PUT(CAR XPR,'MCCOUNT,ADD1 GET(CAR XPR,'MCCOUNT));
%			 COUNTMC CAR XPR>>,
%	  APPEND(EVAL(CAR XPR . 
%				FOR EACH J IN CDR XPR COLLECT MKQUOTE J),
%				CDR Q))
	ELSE IF NOT MEMQ(CAR XPR,'(DEFSYM COMMENT)) THEN MAKEWORD XPR;
	IF LITERALS OR NOT(LOC = LITLOC) THEN GO TO PHAS;
	PASS2LIT:=T;		% Let FASLEVAL know we're doing lits;
	MAPC(OLITERALS,FUNCTION MAKEWORD);
	IF NOT(LOC = (LITLOC+LITCNT)) THEN GO TO PHAS;
	ENTRYPOINTS := REVERSIP ENTRYPOINTS;
	FOR EACH X IN ENTRYPOINTS DO
	  BUFO(IF CADAR X MEMQ FTYPES!* THEN 11 ELSE 9,CDR X,CAR X);
%	DDTSYMS AND IF DDTSYMP THEN FBF LIST('DDTSYMS,DDTSYMS)
%		ELSE FBF LIST("Undefined SYMs made DDTSYMs:",DDTSYMS);
	IF UNDEFSYMS THEN FBF LIST("Undefined:",UNDEFSYMS);
	BASE := 10;
	IF !*FASLMSG THEN WHILE ENTRYPOINTS DO
	   BEGIN SCALAR X; INTEGER Y;
	      X := CAR ENTRYPOINTS;
	      IF CDR ENTRYPOINTS THEN Y := CDADR ENTRYPOINTS
		ELSE Y := LOC;
	      FBF LIST(CAAR X,"processed; Entrypoint =",CDR X,
			", words =",Y);
	      ENTRYPOINTS := CDR ENTRYPOINTS
	   END;
	REMPROPL(CURRENTFNSYMS,'SYM);
%	REMPROPL(DDTSYMS,'SYM);
	SYMPOP SYMPDL;
	RETURN NIL;
   PHAS:FBF LIST('ERR,"Pass 2 phase",CURRENTFN,LOC,LITLOC,LITCNT);
     END)
   (8,8,0);


SYMBOLIC PROCEDURE FASLEVAL X;		% Used only by MAKEWORD;
     IF NUMBERP X THEN X		%  Embedded Pass2 LITs recurse;
ELSE IF ATOM X THEN
	IF X EQ '!* THEN LIST('RELOC,FILOC+LOC) ELSE
	IF GET(X,'SYM) THEN GET(X,'SYM) ELSE
	IF NULL X OR MEMQ(X,UNDEFSYMS) THEN 0 ELSE
	IF GET(X,'MACOP) THEN GET(X,'MACOP) ELSE
%	IF NULL DDTSYMP THEN <<	!&PUSH(X,DDTSYMS);
%				!*DDTSYM X>> ELSE;
	<<!&PUSH(X,UNDEFSYMS); 0>>
ELSE IF CAR X EQ 'QUOTE THEN X		% Could check for GOFOO's...;
ELSE IF MEMQ(CAR X,'(E FLUID FUNCTION ARRAY EVAL)) THEN X
ELSE IF CAR X EQ 'C THEN
%	IF NOT FSLFLD1P() THEN <<FBF "BAD LIT";% 0>> ELSE
%	IF LAPCONST CDR X THEN <<FBF X;% 0>> ELSE;
	IF NOT PASS2LIT THEN
	<<LITERALS:=CDR LITERALS;	% Chop off for phase test;
	  (LAMBDA RLC;
	      <<LITCNT:=LITCNT+
%		IF MEMQ(CADR X,'(ASCII SIXBIT BLOCK)) THEN
%			BLOBLENGTH CDR X ELSE;
		IF RECLITCOUNT(CDR X,NIL)=0 THEN 1
		ELSE <<RLC:=RLC+RECLITCOUNT(CDR X,NIL);	   % Embedded;
		       RLC-LITCNT+1>>;
		LIST('RELOC,FILOC+LITLOC+RLC) >> )
	  LITCNT>>
	ELSE (LAMBDA RLC; <<MAKEWORD CDR X; RLC>> )
		FASLEVAL '!*				% Embedded;
ELSE IF MEMQ(CAR X,'(ASCII SIXBIT SQUOZE !- !+)) THEN <<FBF X; 0>>
ELSE IF CDR X THEN RELOADD(FASLEVAL CAR X,FASLEVAL CDR X)
ELSE FASLEVAL CAR X;

SYMBOLIC PROCEDURE RELOADD(X,Y);
 BEGIN SCALAR A;
  IF NUMBERP X THEN <<A:=X; X:=Y; Y:=A>>;
  IF NUMBERP Y THEN
    IF NUMBERP X THEN RETURN (X + Y)
     ELSE IF EQCAR(X,'RELOC) THEN RETURN
      LIST('RELOC,Y + CADR X);
  ERROR(0,LIST(X,Y,"NON RELOCATABLE"))
 END;

SYMBOLIC PROCEDURE LAPCONST X; NIL;


SYMBOLIC PROCEDURE RECLITCOUNT(XPR,PASS1);
     IF CDR XPR AND				% POPJ P;
	CDDR XPR AND				% MOVE 2 1;
	(XPR:= IF CADDR XPR EQ '!@ OR CADR XPR EQ '!@
		THEN CADDDR XPR ELSE CADDR XPR) AND
	NOT ATOM XPR AND
	CAR XPR EQ 'C AND			% SUB P (C 0 0 2 2);
	NOT LAPCONST CDR XPR THEN
		IF PASS1 THEN <<!&PUSH(CDR XPR,LITERALS); 0>> ELSE
%		IF MEMQ(CADR XPR,'(ASCII SIXBIT BLOCK))
%		    THEN BLOBLENGTH XPR  ELSE;
		RECLITCOUNT(XPR,NIL)+1
     ELSE 0;

%SYMBOLIC PROCEDURE !*DDTSYM X;
%   BEGIN SCALAR Y;
%	FBF LIST("unusual sym",X);
%	IF (Y:=!*GETSYM X) THEN PUT(X,'SYM,Y);
%   END;


SYMBOLIC PROCEDURE COLLECTATOMS X;
   X AND (LAMBDA TYPE;
	     IF TYPE EQ 'SYMBOL THEN IF NULL GET(X,'ATOMINDX)
		THEN << !&PUSH(X,ALLATOMS);
			PUT(X,'ATOMINDX,ATOMINDX:=ATOMINDX+1);
			BUFO(10,0,X)>>  ELSE NIL
	ELSE IF TYPE EQ 'LIST THEN BEGIN LP: COLLECTATOMS CAR X;
		IF ATOM (X:=CDR X) THEN COLLECTATOMS X ELSE GO TO LP END
	ELSE IF MEMQ(TYPE,'(FIXNUM FLONUM BIGNUM STRING)) THEN
		IF NULL ASSOC(X . TYPE,NUMBERTABLE) THEN
		     << !&PUSH((X . TYPE).(ATOMINDX:=ATOMINDX+1),NUMBERTABLE);
			BUFO(10,0,X)>>)
	(TYPEP X);


SYMBOLIC PROCEDURE ATOMINDEX (X,TYPE);
   IF NULL X THEN 0 ELSE
<< IF NULL TYPE THEN TYPE:=TYPEP X;
   TYPE:=IF TYPE EQ 'SYMBOL THEN GET(X,'ATOMINDX) ELSE
	IF MEMQ(TYPE,'(FIXNUM FLONUM BIGNUM STRING))
	AND (TYPE:=ASSOC(X . TYPE,NUMBERTABLE)) THEN CDR TYPE;
   IF TYPE THEN TYPE ELSE FBF LIST('ERR,"Atomindex missing for",X)>>;


SYMBOLIC PROCEDURE FASLDEFSYM (SYM,VAL);
   BEGIN SCALAR Z;
	IF NULL (Z:=GET(SYM,'SYM)) THEN !&PUSH(SYM,CURRENTFNSYMS) ELSE
	IF Z=VAL THEN RETURN Z ELSE
	IF NOT MEMQ(SYM,AMBIGSYMS) THEN
		<<!&PUSH(SYM,AMBIGSYMS);
		  IF NOT MEMQ(SYM,CURRENTFNSYMS) THEN
			MAINSYMPDL:=!&PUSH(SYM.Z,SYMPDL)>>;
	PUT(SYM,'SYM,VAL);
	RETURN VAL;
   END;


SYMBOLIC PROCEDURE TYPEP X;
 IF IDP X THEN 'SYMBOL
  ELSE IF PAIRP X THEN 'LIST
  ELSE IF STRINGP X THEN 'STRING
  ELSE IF BIGP X THEN 'BIGNUM
  ELSE IF FIXP X THEN 'FIXNUM
  ELSE IF FLOATP X THEN 'FLONUM;



SYMBOLIC PROCEDURE BUFO (TYP,N,X);
   BEGIN SCALAR I,SS;
	IF !*FASLDEBUG THEN FBF LIST('BUF!*,TYP,N,X);
	PUTV(BTAR,BINCT,TYP);
	PUTV(BNAR,BINCT,N);
	PUTV(BXAR,BINCT,X);
	IF NOT(TYP EQ 15) AND BINCT<8 THEN RETURN BINCT:=BINCT+1;
	SS:=0;
	FOR I:=0:BINCT DO SS:=SS+ LSH(GETV(BTAR,I),4*(8-I));
	BFBO SS;
	FOR I:=0:BINCT DO
	  BEGIN	TYP:=GETV(BTAR,I);
		N:=GETV(BNAR,I);
		IF TYP<5 OR TYP EQ 6 OR TYP EQ 8 THEN RETURN BFBO N;
		X:=GETV(BXAR,I);
		     IF TYP EQ 5 THEN <<LISTOUT X;
					BFBO BOOLE(7,LSH(-1,18),
						     LSH(N,-18));
					BFBO SXHASH X>>
		ELSE IF TYP EQ 10 THEN (LAMBDA TYPE;
			IF TYPE EQ 'SYMBOL THEN <<SS:=GET(X,'PNAME);
						  BFBO BOOLE(7,
						    IF INTERNP X THEN 0
							ELSE LSH(1,32),
						    LENGTH SS);
						  MAPC(SS,FUNCTION BINV)>>
			ELSE IF TYPE EQ 'STRING THEN
				<<BFBO BOOLE(7,LSH(2,32),LENGTH CDR X);
				  MAPC(CDR X,FUNCTION BINV)>>
			ELSE IF TYPE EQ 'BIGNUM THEN
				<<BFBO BOOLE(7,IF X<0
						  THEN LSH(6,32)
						 ELSE LSH(5,32),
					       LENGTH CDR X);
				  MAPC(REVERSE CDR X,FUNCTION BINV)>>
			ELSE IF TYPE EQ 'FLONUM
			 THEN <<BFBO LSH(4,32); BINV CDR X>>
			ELSE <<BFBO IF TYPE EQ 'FIXNUM THEN LSH(3,32)
				     ELSE LSH(4,32);
			       BFBO X>>)
			(TYPEP X)
		ELSE IF TYP EQ 11 OR TYP EQ 9 THEN
			<<BFBO BOOLE(7,LSH(ATOMINDEX(CAR X,'SYMBOL),18),
					ATOMINDEX(CADR X,'SYMBOL));
			  BFBO BOOLE(7,LSH(CADDR X,18),N)>>
		ELSE IF TYP EQ 14 THEN <<LISTOUT X; BFBO N>>
		ELSE IF TYP EQ 15 THEN BFBO (-30863143776)
		ELSE IF TYP EQ 7 THEN <<BFBO N; X AND BFBO X>>
		ELSE IF TYP EQ 13 THEN BFBO SQUOZE LIST X
		ELSE FBF LIST('ERR,"BUFO args:",TYP,N,X);
	  END;
	RETURN BINCT:=0;
   END;


SYMBOLIC PROCEDURE LISTOUT X;
   (LAMBDA TYPE;
	IF NOT(TYPE EQ 'LIST) THEN BFBO ATOMINDEX(X,TYPE) ELSE
	(BEGIN SCALAR I,Y;
		I:=0;  Y:=X;
	  LP:	IF ATOM Y THEN
		 RETURN BFBO BOOLE(7,I,IF Y THEN <<LISTOUT Y;
						   LSH(2,33)>>
					    ELSE   LSH(1,33));
		LISTOUT CAR Y;
		I:=I+1;  Y:=CDR Y;
		GO LP;
	 END))
   (TYPEP X);

SYMBOLIC PROCEDURE SXHASH X; 0;
SYMBOLIC PROCEDURE SQUOZE X; 0;

%SYMBOLIC PROCEDURE BLOBLENGTH X;
%   FBF LIST('BLOBLENGTH,X);


SYMBOLIC PROCEDURE SYMPOP L;
   MAPC(L,FUNCTION (LAMBDA X; PUT(CAR X,'SYM,CDR X)));

SYMBOLIC PROCEDURE REMPROPL(L,PROP);
	MAPC(L,FUNCTION(LAMBDA X; REMPROP(X,PROP)));


SYMBOLIC PROCEDURE FBF L;
   IF CAR L EQ 'ERR THEN ERROR(0,L) ELSE WARNING L;

SYMBOLIC PROCEDURE BFBO X;
   IF !*FASLDEBUG THEN FBF LIST('BINO,LSH(X,-18),LSH(LSH(X,18),-18))
		ELSE BINO X;

SYMBOLIC PROCEDURE BINV X;  BFBO EXAMINE !*BOX X;

%  SYMBOLIC PROCEDURE BINO X;% NIL;			% For debugging;


SYMBOLIC PROCEDURE MAKEWORD L;
   BEGIN SCALAR WRK,LSUM,RLC,A,B,C,SL,FSLFLD,F1;
	IF !*FASLDEBUG THEN FBF LIST("MW  ",L);
	IF MEMQ(CAR L,'(ASCII SIXBIT BLOCK SQUOZE)) THEN GO TO ERR;
	LSUM:=RLC:=0;
	WRK:=L;
	FSLFLD:='((MACOP) (23 . 15) (0 . 262143) (18 . -1));
WA:	IF NULL WRK THEN GO TO XIT;
	A:= CAR WRK;
	IF A EQ '!@ THEN <<LSUM:=LSUM+LSH(1,22);WRK:= CDR WRK;GO TO WA>>;
	IF NOT NUMBERP(B:=FASLEVAL A) THEN GO TO NNM;
WC:	LSUM:=LSUM+ IF CAR(SL:=CAR FSLFLD) EQ 'MACOP THEN
			LSH(B,IF B<512 THEN 27 ELSE 18)
		ELSE LSH(BOOLE(1,CDR SL,B),CAR SL);
	WRK:=CDR WRK;
	IF (FSLFLD:=CDR FSLFLD) THEN GO TO WA;
XIT:	LOC:=LOC+1;
	BUFO (RLC,LSUM,IF RLC EQ 5 THEN F1 ELSE NIL);
	RETURN NIL;
NNM:	IF B EQ 'FOO THEN GO TO ERR;
	A:=CAR B;
	B:= CAR (C:=CDR B);
	IF NUMBERP A THEN GO TO NUM ELSE
	IF NOT(CAAR FSLFLD=0) THEN GO TO ERR ELSE
	IF A EQ 'RELOC THEN GO TO REL ELSE
	IF A EQ 'FLUID THEN GO TO FLU ELSE
	IF MEMQ(A,'(QUOTE E FUNCTION)) THEN GO TO QUO;
ERR:	FBF LIST("Unimplemented or error",L);	% ARRAY, EVAL, etc;
	LSUM:=RLC:=0;
	GO TO XIT;
REL:	RLC:=1;
	IF CDR C THEN GO TO ERR ELSE GO TO WC;
NUM:	B:=A;
	IF C THEN GO TO ERR ELSE GO TO WC;
FLU:	COLLECTATOMS B;
	IF NOT (A:= TYPEP B) EQ 'SYMBOL THEN GO TO ERR;
	B:= ATOMINDEX(B,A);
	RLC:=2;
	GO TO WC;
QUO:	COLLECTATOMS B;
	IF (A:= TYPEP B) EQ 'LIST THEN
		<<F1:=B; B:=0; RLC:=5; GO TO WC>>;
	B:= ATOMINDEX(B,A);
	IF MEMQ(CAR L,'(CALL JCALL)) THEN RLC:=3 ELSE RLC:=4;
	GO TO WC;
   END;


UNFLUID '(MSGCHN!* FSLCHN!*
	FILE CFL!* BTIME!*
	FASLOUTFILE USERFORF OFILE PROP BASE IBASE
	XPR DDTSYMS UNDEFSYMS SYM LITERALS NUMBERTABLE 
	ENTRYPOINTS
     ALLATOMS AMBIGSYMS ATOMINDX BFUNCS BINCT CURRENTFNSYMS 
     CURRENTFN DDTSYMP DDTSYMS !*FASLDEBUG FILOC LITCNT 
     LITERALS LITLOC LOC MAINSYMPDL NUMBERTABLE PASS2LIT SYMBOLSP 
     SYMPDL UNDEFSYMS WINP
);



COMMENT EQCAR and MKQUOTE defined to use FAP in LISP;

SYMBOLIC PROCEDURE EQCAR(U,V);
 PAIRP U AND CAR U EQ V;

SYMBOLIC PROCEDURE MKQUOTE U; LIST('QUOTE,U);


END;