Artifact 463ac0541299e64519b145a915f58078394350ad5f4352f37879d52e739b771c:
- Executable file
r36/src/rlisp.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 123036) [annotate] [blame] [check-ins using] [more...]
module rlisp; % Header module for rlisp package. % Author: Anthony C. Hearn. global '(date!* patch!-date!* version!*); create!-package('(rlisp newtok support slfns superv tok xread lpri parser block form proc forstat loops statmisc smacro io infix switch where list array inter), nil); if patch!-date!* then date!* := compress('!" . append(explode2 "15-Jul-95, patched to ", nconc(explode2 patch!-date!*,list '!"))) else date!* := "15-Jul-95"; version!* := "REDUCE 3.6"; % Hook to Rlisp88. put('rlisp88,'simpfg,'((t (load!-package 'rlisp88) (rlisp88!_on)))); flag('(rlisp88),'switch); endmodule; module newtok; % Functions for introducing infix tokens to the system. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*msg !*redeflg!*); global '(preclis!* fixedpreclis!*); % Several operators in REDUCE are used in an infix form (e.g., +,- ). % The internal alphanumeric names associated with these operators are % introduced by the function NEWTOK defined below. This association, % and the precedence of each infix operator, is initialized in this % section. We also associate printing characters with each internal % alphanumeric name as well. fixedpreclis!* := '(!*comma!* setq); preclis!*:= '(or and member memq equal neq eq geq greaterp leq % not lessp freeof plus difference times quotient expt cons); deflist ('( % (not not) (plus plus) (difference minus) (minus minus) (times times) (quotient recip) (recip recip) ), 'unary); flag ('(and or !*comma!* plus times),'nary); flag ('(cons setq plus times),'right); deflist ('((minus plus) (recip times)),'alt); symbolic procedure mkprec; begin scalar x,y,z; x := append(fixedpreclis!*,preclis!*); y := 1; a: if null x then return nil; put(car x,'infix,y); put(car x,'op,list list(y,y)); % for RPRINT. if z := get(car x,'unary) then put(z,'infix,y); if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y)); x := cdr x; y := add1 y; go to a end; mkprec(); symbolic procedure newtok u; begin scalar !*redeflg!*,x,y; if atom u or atom car u or null idp caar u then typerr(u,"NEWTOK argument"); % set up SWITCH* property. put(caar u,'switch!*, cdr newtok1(car u,cadr u,get(caar u,'switch!*))); % set up PRTCH property. y := intern compress consescc car u; if !*redeflg!* then lprim list(y,"redefined"); put(cadr u,'prtch,y); if x := get(cadr u,'unary) then put(x,'prtch,y) end; symbolic procedure newtok1(charlist,name,propy); if null propy then lstchr(charlist,name) else if null cdr charlist then begin if cdr propy and !*msg then !*redeflg!* := t; return list(car charlist,car propy,name) end else car charlist . newtok2(cdr charlist,name,car propy) . cdr propy; symbolic procedure newtok2(charlist,name,assoclist); if null assoclist then list lstchr(charlist,name) else if car charlist eq caar assoclist then newtok1(charlist,name,cdar assoclist) . cdr assoclist else car assoclist . newtok2(charlist,name,cdr assoclist); symbolic procedure consescc u; if null u then nil else '!! . car u . consescc cdr u; symbolic procedure lstchr(u,v); if null cdr u then list(car u,nil,v) else list(car u,list lstchr(cdr u,v)); newtok '((!$) !*semicol!*); newtok '((!;) !*semicol!*); newtok '((!+) plus); newtok '((!-) difference); newtok '((!*) times); newtok '((!^) expt); newtok '((!* !*) expt); newtok '((!/) quotient); newtok '((!=) equal); newtok '((!,) !*comma!*); newtok '((!() !*lpar!*); newtok '((!)) !*rpar!*); newtok '((!:) !*colon!*); newtok '((!: !=) setq); newtok '((!.) cons); newtok '((!<) lessp); newtok '((!< !=) leq); newtok '((!< !<) !*lsqbkt!*); newtok '((!>) greaterp); newtok '((!> !=) geq); newtok '((!> !>) !*rsqbkt!*); put('expt,'prtch,'!*!*); % To ensure that FORTRAN output is correct. flag('(difference minus plus setq),'spaced); flag('(newtok),'eval); endmodule; module support; % Basic functions needed to support RLISP and REDUCE. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace); global '(!*comp); symbolic procedure aconc(u,v); % Adds element v to the tail of u. u is destroyed in process. nconc(u,list v); symbolic procedure arrayp u; get(u,'rtype) eq 'array; symbolic procedure atsoc(u,v); % This definition allows for a search of a general list. if null v then nil else if eqcar(car v,u) then car v else atsoc(u,cdr v); symbolic procedure copyd(new,old); % Copy the function definition from old id to new. begin scalar x; x := getd old; if null x then rerror('rlisp,1,list(old,"has no definition in copyd")); putd(new,car x,cdr x); return new end; symbolic procedure eqcar(u,v); null atom u and car u eq v; symbolic procedure errorset!*(u,v); errorset(u,v,!*backtrace); symbolic procedure errorset2 u; begin scalar !*protfg; !*protfg := t; return errorset(u,nil,nil) end; symbolic procedure flagpcar(u,v); null atom u and idp car u and flagp(car u,v); symbolic procedure idlistp u; % True if u is a list of id's. null u or null atom u and idp car u and idlistp cdr u; symbolic procedure listp u; % Returns T if U is a top level list. null u or null atom u and listp cdr u; symbolic procedure mkprog(u,v); 'prog . (u . v); symbolic procedure mkquote u; list('quote,u); symbolic procedure mksetq(u,v); if atom u then list('setq,u,v) else begin scalar x; if (x := get(car u,'setfn)) then return apply2(x,u,v) else typerr(u,"assignment argument") end; symbolic procedure pairvars(u,vars,mode); % Sets up pairings of parameters and modes. begin scalar x; a: if null u then return append(reversip!* x,vars) else if null idp car u or get(car u,'infix) or get(car u,'stat) then symerr(list("Invalid parameter:",car u),nil); x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure prin2t u; progn(prin2 u, terpri(), u); % The following is included for compatibility with some old code. % Its use is discouraged. symbolic procedure princ u; prin2 u; symbolic procedure putc(name,type,body); % Defines a non-standard function, such as an smacro. Returns NAME. begin if !*comp and flagp(type,'compile) then compd(name,type,body) else put(name,type,body); return name end; % flag('(putc),'eval); symbolic procedure reversip u; begin scalar x,y; a: if null u then return y; x := cdr u; y := rplacd(u,y); u := x; go to a end; symbolic procedure smemq(u,v); % True if id U is a member of V at any level (excluding quoted % expressions). if atom v then u eq v else if car v eq 'quote then nil else smemq(u,car v) or smemq(u,cdr v); symbolic procedure subsetp(u,v); % True if u is a subset of v. null u or car u member v and subsetp(cdr u,v); symbolic procedure union(x,y); if null x then y else union(cdr x,if car x member y then y else car x . y); symbolic procedure intersection(u,v); % This definition is consistent with PSL. if null u then nil else if car u member v then car u . intersection(cdr u,delete(car u,v)) else intersection(cdr u,v); symbolic procedure u>=v; null(u<v); symbolic procedure u<=v; null(u>v); symbolic procedure u neq v; null(u=v); symbolic procedure setdiff(u,v); if null v then u else if null u then nil else setdiff(delete(car v,u),cdr v); % symbolic smacro procedure u>=v; null(u<v); % symbolic smacro procedure u<=v; null(u>v); % symbolic smacro procedure u neq v; null(u=v); % List changing alternates (may also be defined as copying functions). symbolic procedure aconc!*(u,v); nconc(u,list v); % append(u,list v); symbolic procedure nconc!*(u,v); nconc(u,v); % append(u,v); symbolic procedure reversip!* u; reversip u; % reverse u; symbolic procedure rplaca!*(u,v); rplaca(u,v); % v . cdr u; symbolic procedure rplacd!*(u,v); rplacd(u,v); % car u . v; % The following functions should be provided in the compiler for % efficient coding. symbolic procedure lispapply(u,v); % I'd like to use idp in the following test, but the TPS package % stores code pointers on property lists which then get used here. if null atom u then rerror('rlisp,2,list("Apply called with non-id arg",u)) else apply(u,v); symbolic procedure lispeval u; eval u; symbolic procedure apply1(u,v); apply(u,list v); symbolic procedure apply2(u,v,w); apply(u,list(v,w)); symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x)); % The following function is needed by several modules. It is more % REDUCE-specific than other functions in this module, but since it % needs to be defined early on, it might as well go here. symbolic procedure gettype u; % Returns a REDUCE-related type for the expression U. % It needs to be more table driven than the current definition. if numberp u then 'number else if null atom u or null u or null idp u then 'form else if get(u,'simpfn) then 'operator else if get(u,'avalue) then car get(u,'avalue) else if getd u then 'procedure else if globalp u then 'global else if fluidp u then 'fluid else if flagp(u,'parm) then 'parameter else get(u,'rtype); endmodule; module slfns; % Complete list of Standard LISP functions. % Author: Anthony C. Hearn. global '(!*argnochk slfns!*); slfns!* := '( (abs 1) (add1 1) (append 2) (apply 2) (assoc 2) (atom 1) (car 1) (cdr 1) (caar 1) (cadr 1) (cdar 1) (cddr 1) (caaar 1) (caadr 1) (cadar 1) (caddr 1) (cdaar 1) (cdadr 1) (cddar 1) (cdddr 1) (caaaar 1) (caaadr 1) (caadar 1) (caaddr 1) (cadaar 1) (cadadr 1) (caddar 1) (cadddr 1) (cdaaar 1) (cdaadr 1) (cdadar 1) (cdaddr 1) (cddaar 1) (cddadr 1) (cdddar 1) (cddddr 1) (close 1) (codep 1) (compress 1) (cons 2) (constantp 1) (de 3) (deflist 2) (delete 2) % (df 3) conflicts with algebraic operator DF (difference 2) (digit 1) (divide 2) (dm 3) % (dn 3) % (ds 3) (eject 0) (eq 2) (eqn 2) (equal 2) (error 2) (errorset 3) (eval 1) (evlis 1) (expand 2) (explode 1) (expt 2) (fix 1) (fixp 1) (flag 2) (flagp 2) (float 1) (floatp 1) (fluid 1) (fluidp 1) (function 1) (gensym 0) (get 2) (getd 1) (getv 2) (global 1) (globalp 1) (go 1) (greaterp 2) (idp 1) (intern 1) (length 1) (lessp 2) (linelength 1) (liter 1) (lposn 0) (map 2) (mapc 2) (mapcan 2) (mapcar 2) (mapcon 2) (maplist 2) (max2 2) (member 2) (memq 2) (minus 1) (minusp 1) (min2 2) (mkvect 1) (nconc 2) (not 1) (null 1) (numberp 1) (onep 1) (open 2) (pagelength 1) (pair 2) (pairp 1) (plus2 2) (posn 0) (print 1) (prin1 1) (prin2 1) (prog2 2) (put 3) (putd 3) (putv 3) (quote 1) (quotient 2) (rds 1) (read 0) (readch 0) (remainder 2) (remd 1) (remflag 2) (remob 1) (remprop 2) (return 1) (reverse 1) (rplaca 2) (rplacd 2) (sassoc 3) (set 2) (setq 2) (stringp 1) (sublis 2) (subst 3) (sub1 1) (terpri 0) (times2 2) (unfluid 1) (upbv 1) (vectorp 1) (wrs 1) (zerop 1) ); if !*argnochk then deflist(slfns!*,'number!-of!-args); endmodule; module superv; % REDUCE supervisory functions. % Author: Anthony C. Hearn. % Modified by: Jed B. Marti. % Copyright (c) 1991 RAND. All rights reserved. fluid '(!*defn !*demo !*echo !*errcont !*int !*lisp!_hook !*mode !*output !*pret !*slin !*time dfprint!* loopdelimslist!* lreadfn!* semic!* tslin!*); global '(!$eof!$ !*byeflag!* !*extraecho !*lessspace !*micro!-version !*nosave!* !*strind !*struct cloc!* cmsg!* crbuf!* crbuflis!* crbuf1!* curline!* cursym!* eof!* erfg!* forkeywords!* ifl!* ipl!* initl!* inputbuflis!* key!* ofl!* opl!* ogctime!* otime!* program!* programl!* promptexp!* repeatkeywords!* resultbuflis!* st!* statcounter symchar!* tok!* ttype!* whilekeywords!* ws); !*output := t; eof!* := 0; initl!* := '(fname!* outl!*); statcounter := 0; % The true REDUCE supervisory function is BEGIN, again defined in the % system dependent part of this program. However, most of the work is % done by BEGIN1, which is called by BEGIN for every file encountered % on input; symbolic procedure errorp u; %returns true if U is an ERRORSET error format; atom u or cdr u; symbolic procedure printprompt u; %Prints the prompt expression for input; progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*); symbolic procedure setcloc!*; % Used to set for file input a global variable CLOC!* to dotted pair % of file name and dotted pair of line and page being read. % Currently a place holder for system specific function, since not % supported in Standard LISP. CLOC!* is used in the INTER and RCREF % modules. cloc!* := if null ifl!* then nil else car ifl!* . (1 . curline!*); symbolic procedure command1; % Innermost part of COMMAND. Can be used as hook to editor if needed. begin scan(); setcloc!*(); key!* := cursym!*; return xread1 nil end; symbolic procedure commdemo; begin scalar echo,x,y,z,!*demo; echo := !*echo; !*echo := nil; x := ifl!*; terpri(); rds nil; y:=readch(); if null seprp y then % Read command line from terminal. begin scalar crbuf,crbuf1,crchar,ifl; crbuf := crbuf!*; crbuf!* := nil; crbuf1 := crbuf1!*; crbuf1!* := list y; crchar := crchar!*; crchar!* := '! ; ifl := ifl!*; ifl!* := nil; z := errorset!*('(command),t); z := if errorp z then '(algebraic(aeval 0)) else car z; % eat rest of line quietly. q: y := readch(); if y neq !$eol!$ then go to q; rds cadr x; crbuf!* := crbuf; crbuf1!* := crbuf1; crchar!* := crchar; ifl!* := ifl; !*echo := echo; end else % Read command from current input. progn(rds cadr x, !*echo := echo, z := command()); return z end; symbolic procedure command; begin scalar loopdelimslist!*,mode,x,y; if !*demo and ifl!* then return commdemo() else if null !*slin then go to a; % Note key!* not set in this case. setcloc!*(); y := if lreadfn!* then lispapply(lreadfn!*,nil) else read(); go to b; a: crchar!* := readch1(); % Initialize crchar!*. if crchar!* = !$eol!$ then go to a; y := command1(); b: if !*struct then y := structchk y; if !*pret then progn(terpri(),rprint y); if !*slin then return list('symbolic,y); x := form y; % Determine target mode. if flagp(key!*,'modefn) then mode := key!* else if null atom x % and null !*micro!-version and null(car x eq 'quote) and (null(idp car x and (flagp(car x,'nochange) or flagp(car x,'intfn) or car x eq 'list)) or car x memq '(setq setel setf) and eqcar(caddr x,'quote)) then mode := 'symbolic else mode := !*mode; return list(mode,convertmode1(x,nil,'symbolic,mode)) end; symbolic procedure begin1; begin scalar mode,parserr,result,x; otime!* := time(); % the next line is that way for bootstrapping purposes. if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0; cursym!* := '!*semicol!*; a: if null terminalp() or !*nosave!* then go to b else if statcounter>0 then add2buflis(); statcounter := statcounter + 1; % crbuf1!* := nil; % For input string editor. !*strind := 0; % Used by some versions of input editor. promptexp!* := compress('!! . append(explode statcounter, explode if null symchar!* or !*mode eq 'algebraic then '!:! else '!*! )); setpchar promptexp!*; b: parserr := nil; !*nosave!* := nil; if !*time then lispeval '(showtime); %Since a STAT; if !*output and null ofl!* and terminalp() and null !*defn and null !*lessspace then terpri(); if tslin!* then progn(!*slin := car tslin!*, lreadfn!* := cdr tslin!*, tslin!* := nil); x := initl!*; b0: if x then progn(sinitl car x, x := cdr x, go to b0); remflag(forkeywords!*,'delim); remflag(repeatkeywords!*,'delim); remflag( whilekeywords!*,'delim); if !*int then erfg!* := nil; %to make editing work properly; if cursym!* eq 'end then progn(comm1 'end, return nil) % Note that key* was set from *previous* command in following. else if terminalp() and null(key!* eq 'ed) then printprompt promptexp!*; x := errorset!*('(command),t); condterpri(); if errorp x then go to err1; x := car x; if cursym!* eq 'end then if terminalp() and null !*lisp!_hook then progn(cursym!* := '!*semicol!*, go to b) else progn(comm1 'end, return nil) else if eqcar(cadr x,'retry) then if programl!* then x := programl!* else progn(lprim "No previous expression",go to a); mode := car x; x := cadr x; program!* := x; % Keep it around for debugging purposes. if eofcheck() then go to c else eof!* := 0; add2inputbuf(x,mode); if null atom x and car x memq '(bye quit) then if getd 'bye then progn(lispeval x, go to b) else progn(!*byeflag!* := t, return nil) else if eqcar(x,'ed) then progn((if getd 'cedit and terminalp() then cedit cdr x else lprim "ED not supported"), go to b) else if !*defn then if erfg!* then go to a else if null flagp(key!*,'ignore) and null eqcar(x,'quote) then go to d; b1: if !*output and ifl!* and !*echo and null !*lessspace then terpri(); result := errorset!*(x,t); if errorp result or erfg!* then progn(programl!* := list(mode,x),go to err2) else if !*defn then go to a; if null(mode eq 'symbolic) then x := getsetvars x; add2resultbuf(car result,mode); if null !*output then go to a else if null(semic!* eq '!$) then if mode eq 'symbolic then if null car result and null(!*mode eq 'symbolic) then nil else begin terpri(); result:= errorset!*(list('print,mkquote car result), t) end else if car result then result := errorset!*(list('assgnpri,mkquote car result, (if x then 'list . x else nil), mkquote 'only), t); if errorp result then go to err3 else go to a; c: if crbuf1!* then progn(lprim "Closing object improperly removed. Redo edit.", crbuf1!* := nil, go to a) else if eof!*>4 then progn(lprim "End-of-file read", return lispeval '(bye)) else if terminalp() then progn(crbuf!* := nil, go to b) else return nil; d: if x then dfprint x; if null flagp(key!*,'eval) then go to a else go to b1; err1: if eofcheck() or eof!*>0 then go to c else if x="BEGIN invalid" then go to a; parserr := t; err2: resetparser(); %in case parser needs to be modified; err3: erfg!* := t; if null !*int and null !*errcont then progn(!*defn := t, !*echo := t, (if null cmsg!* then lprie "Continuing with parsing only ..."), cmsg!* := t) else if null !*errcont then progn(result := pause1 parserr, (if result then return null lispeval result), erfg!* := nil) else erfg!* := nil; go to a end; symbolic procedure getsetvars u; if atom u then nil else if car u memq '(setel setk) % setk0. then cadr u . getsetvars caddr u else if car u eq 'setq then mkquote cadr u . getsetvars caddr u else nil; flag ('(deflist flag fluid global remflag remprop unfluid),'eval); symbolic procedure close!-input!-files; % Close all input files currently open; begin if ifl!* then progn(rds nil,ifl!* := nil); aa: if null ipl!* then return nil; close cadar ipl!*; ipl!* := cdr ipl!*; go to aa end; symbolic procedure close!-output!-files; % Close all output files currently open; begin if ofl!* then progn(wrs nil,ofl!* := nil); aa: if null opl!* then return nil; close cdar opl!*; opl!* := cdr opl!*; go to aa end; symbolic procedure add2buflis; begin if null crbuf!* then return nil; crbuf!* := reversip crbuf!*; %put in right order; a: if crbuf!* and seprp car crbuf!* then progn(crbuf!* := cdr crbuf!*, go to a); crbuflis!* := (statcounter . crbuf!*) . crbuflis!*; crbuf!* := nil end; symbolic procedure add2inputbuf(u,mode); begin if null terminalp() or !*nosave!* then return nil; inputbuflis!* := list(statcounter,mode,u) . inputbuflis!* end; symbolic procedure add2resultbuf(u,mode); begin if mode eq 'symbolic or null u or !*nosave!* then return nil; ws := u; if terminalp() then resultbuflis!* := (statcounter . u) . resultbuflis!* end; symbolic procedure condterpri; !*output and !*echo and !*extraecho and (null !*int or ifl!*) and null !*defn and null !*demo and terpri(); symbolic procedure eofcheck; % true if an end-of-file has been read in current input sequence; program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1); symbolic procedure resetparser; %resets the parser after an error; if null !*slin then comm1 t; symbolic procedure terminalp; %true if input is coming from an interactive terminal; !*int and null ifl!*; symbolic procedure dfprint u; %Looks for special action on a form, otherwise prettyprints it; if dfprint!* then lispapply(dfprint!*,list u) else if cmsg!* then nil else if null eqcar(u,'progn) then prettyprint u else begin a: u := cdr u; if null u then return nil; dfprint car u; go to a end; symbolic procedure showtime; begin scalar x,y; x := otime!*; otime!* := time(); x := otime!* - x; y := ogctime!*; ogctime!* := gctime(); y := ogctime!* - y; x := x - y; terpri(); prin2 "Time: "; prin2 x; prin2 " ms"; if y = 0 then return terpri(); prin2 " plus GC time: "; prin2 y; prin2 " ms" end; symbolic procedure sinitl u; set(u,eval get(u,'initl)); endmodule; module tok; % Identifier and reserved character reading. % Author: Anthony C. Hearn. % Modifications by: Arthur Norman. % Copyright (c) 1995 RAND. All rights reserved. fluid '(!*adjprec !*defn !*eoldelimp !*lower !*minusliter !*quotenewnam semic!*); % Note *raise is global in following for consistency with the SL Report. global '(!$eof!$ !$eol!$ !*micro!-version !*raise !*saveComments!* comment!* crbuf!* crbuf1!* crchar!* curline!* cursym!* eof!* ifl!* nxtsym!* outl!* ttype!*); flag('(adjprec),'switch); !*quotenewnam := t; crchar!* := '! ; curline!* := 1; % The function TOKEN defined below is used for reading identifiers % and reserved characters (such as parentheses and infix operators). % It is called by the function SCAN, which translates reserved % characters into their internal name, and sets up the output of the % input line. The following definitions of TOKEN and SCAN are quite % general, but also inefficient. The reading process can often be % speeded up considerably if these functions (especially token) are % written in terms of the explicit LISP used. symbolic procedure prin2x u; outl!* := u . outl!*; symbolic procedure mkstrng u; %converts the uninterned id U into a string; %if strings are not constants, this should be replaced by %list('string,u); u; symbolic procedure readch1; begin scalar x; if null terminalp() then progn(x := readch(), x eq !$eol!$ and (curline!* := curline!*+1), return x) else if crbuf1!* then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end else x := readch(); crbuf!* := x . crbuf!*; return x end; symbolic procedure tokquote; begin crchar!* := readch1(); nxtsym!* := mkquote rread(); ttype!* := 4; return nxtsym!* end; put('!','tokprop,'tokquote); symbolic procedure token!-number x; % Read and return a valid number from input. begin scalar dotp,power,sign,y,z; power := 0; ttype!* := 2; num1: if y or null(x eq '!)) then y := x . y; if dotp then power := power - 1; num2: if (x := readch1()) eq '!. then if dotp then rerror('rlisp,3,"Syntax error: improper number") else progn(dotp := t, go to num2) else if digit x then go to num1 else if null(x eq 'e) then go to ret; % Case of number with embedded or trailing E. dotp := t; if (x := readch1()) eq '!- then sign := t else if x eq '!+ then nil else if null digit x then go to ret else z := list x; nume1: if null digit(x := readch1()) then go to nume2; z := x . z; go to nume1; nume2: if null z then rerror('rlisp,4,"Syntax error: improper number"); z := compress reversip!* z; if sign then power := power - z else power := power + z; ret: y := compress reversip!* y; nxtsym!* := if dotp then '!:dn!: . (y . power) else if !*adjprec then '!:int!: . (y . nil) else y; crchar!* := x; return nxtsym!* end; symbolic procedure token1; begin scalar x,y; x := crchar!*; a: if seprp x and null(x eq !$eol!$ and !*eoldelimp) then progn(x := readch1(), go to a) else if digit x then return token!-number x else if liter x then go to letter else if (y := get(x,'tokprop)) then return lispapply(y,nil) else if x eq '!% and null !*saveComments!* then go to coment else if x eq '!! and null(!*micro!-version and null !*defn) then go to escape else if x eq '!" then go to string; ttype!* := 3; if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr()); nxtsym!* := x; if delcp x then crchar!*:= '! else crchar!*:= readch1(); if null(x eq '!- and digit crchar!* and !*minusliter) then go to c; x := token!-number crchar!*; if numberp x then return apply1('minus,x); % For bootstrapping. rplaca(cdr x,apply1('minus,cadr x)); % Also for booting. return x; escape: begin scalar raise,!*lower; raise := !*raise; !*raise := nil; y := x . y; x := readch1(); !*raise := raise end; letter: ttype!* := 0; let1: y := x . y; if digit (x := readch1()) or liter x then go to let1 else if x eq '!! then go to escape else if x eq '!- and !*minusliter then progn(y := '!! . y, go to let1) else if x eq '!_ then go to let1; % Allow _ as letter. nxtsym!* := intern compress reversip!* y; crchar!* := x; c: return nxtsym!*; % minusl: % if digit (x := readch1()) % then progn(crchar!* := x, return(nxtsym!* := 'minus)) % else progn(y := '!- . '!! . y, go to letter); string: begin scalar raise,!*lower; raise := !*raise; !*raise := nil; strinx: y := x . y; if (x := readch1()) eq !$eof!$ then progn(!*raise := raise, crchar!* := '! , lpriw("***** End-of-file in string",nil), filenderr()) else if null(x eq '!") then go to strinx; y := x . y; % Now check for embedded string character. x := readch1(); if x eq '!" then go to strinx; nxtsym!* := mkstrng compress reversip!* y; !*raise := raise end; ttype!* := 1; crchar!* := x; go to c; coment: if null(readch1() eq !$eol!$) then go to coment; x := readch1(); go to a end; symbolic procedure tokbquote; begin crchar!* := readch1(); nxtsym!* := list('backquote,rread()); ttype!* := 3; return nxtsym!* end; put('!`,'tokprop,'tokbquote); symbolic procedure token; %This provides a hook for a faster TOKEN; token1(); symbolic procedure filenderr; begin eof!* := eof!*+1; if terminalp() then error1() else error(99,if ifl!* then list("End-of-file read in file",car ifl!*) else "End-of-file read") end; symbolic procedure ptoken; begin scalar x; x := token(); if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*; %an explicit reference to OUTL!* used here; prin2x x; if null ((x eq '!() or (x eq '!))) then prin2x '! ; return x end; symbolic procedure rread1; % Modified to use QUOTENEWNAM's for ids. % Note that handling of reals uses symbolic mode, regardless of % actual mode. begin scalar x,y; x := ptoken(); if null (ttype!*=3) then return if idp x then if !*quotenewnam and (y := get(x,'quotenewnam)) then y else x else if eqcar(x,'!:dn!:) then dnform(x,nil,'symbolic) else x else if x eq '!( then return rrdls() else if null (x eq '!+ or x eq '!-) then return x; y := ptoken(); if eqcar(y,'!:dn!:) then y := dnform(y,nil,'symbolic); if null numberp y then progn(nxtsym!* := " ", symerr("Syntax error: improper number",nil)) else if x eq '!- then y := apply1('minus,y); % We need this construct for bootstrapping purposes. return y end; symbolic procedure rrdls; begin scalar x,y,z; a: x := rread1(); if null (ttype!*=3) then go to b else if x eq '!) then return z else if null (x eq '!.) then go to b; x := rread1(); y := ptoken(); if null (ttype!*=3) or null (y eq '!)) then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil)) else return nconc(z,x); b: z := nconc(z,list x); go to a end; symbolic procedure rread; progn(prin2x " '",rread1()); symbolic procedure delcp u; % Returns true if U is a semicolon, dollar sign, or other delimiter. % This definition replaces the one in the BOOT file. flagp(u,'delchar); flag('(!; !$),'delchar); symbolic procedure toknump x; numberp x or eqcar(x,'!:dn!:) or eqcar(x,'!:int!:); % The following version of SCAN provides RLISP with a facility for % conditional compilation. The protocol is that text is included or % excluded at the level of tokens. Control by use of new reserved % tokens !#if, !#else and !#endif. These are used in the form: % !#if (some Lisp expression for use as a condition) % ... RLISP input ... % !#else % ... alternative RLISP input ... % !#endif % % The form % !#if C1 ... !#elif C2 ... !#elif C3 ... !#else ... !#endif % is also supported. % % Conditional compilation can be nested. If the Lisp expression used % to guard a condition causes an error it is taken to be a FALSE % condition. It is not necessary to have an !#else before !#endif if no % alternative text is needed. Although the examples here put !#if etc % at the start of lines this is not necessary (though it may count as % good style?). Since the condition will be read using RLISPs own % list-reader there could be conditional compilation guarding parts of % it - the exploitation of that possibility is to be discouraged! % Making the condition a raw Lisp expression makes sure that parsing it % is easy. It makes it possible to express arbitrary conditions, but it % is hoped that most conditions will not be very elaborate - things like % !#if (not (member 'csl lispsystem!*)) % error(); % !#else % magic(); % !#endif % or % !#if debugging!-mode % NB if variable is unset that counts as nil % print "message"; % so care should be taken to select the most % !#endif % useful default sense for such tests % should be about as complicated as reasonable people need. % % Two further facilities are provided: % !#eval (any lisp expression) % causes that expression to be evaluated at parse time. Apart from any % side-effects in the evaluation the text involved is all ignored. It is % expected that this will only be needed in rather curious cases, for % instance to set system-specific options for a compiler. % !#define symbol value % where the value should be another symbol, a string or a number, % causes the first symbol to be mapped onto the second value wherever % it occurs in subsequent input. This uses exactly the same mechanism % as the existing REDUCE "define" statement and so has the same % limitations. The use of a hook in SCAN to support this ensures that % the !#define can be written anywhere in REDUCE source code (eg within % a procedure definition) and will still apply while the program % involved is parsed. No special facility for undoing the effect of a % !#define is provided, but the general-purpose !#eval could be used to % remove the 'newnam property that is involved. symbolic procedure scan; begin scalar bool,x,y; if null (cursym!* eq '!*semicol!*) then go to b; a: nxtsym!* := token(); b: if null atom nxtsym!* and null toknump nxtsym!* then go to q1 else if nxtsym!* eq 'else or cursym!* eq '!*semicol!* then outl!* := nil; prin2x nxtsym!*; c: if null idp nxtsym!* then go to l else if (x:=get(nxtsym!*,'newnam)) and (null (x=nxtsym!*)) then go to new else if nxtsym!* eq 'Comment then go to comm else if nxtsym!* eq '!#if then go to conditional else if nxtsym!* eq '!#else or nxtsym!* eq '!#elif then progn(nxtsym!* := x := nil, go to skipping) else if nxtsym!* eq '!#endif then go to a else if nxtsym!* eq '!#eval then progn( errorset(rread(), !*backtrace, nil), go to a) else if nxtsym!* eq '!#define then progn( x := errorset(rread(), !*backtrace, nil), progn(if errorp x then go to a), y := errorset(rread(), !*backtrace, nil), progn(if errorp y then go to a), put(x, 'newnam, y), go to a) else if null(ttype!* = 3) then go to l else if nxtsym!* eq !$eof!$ then return filenderr() else if nxtsym!* eq '!' then rederr "Invalid QUOTE" else if !*eoldelimp and nxtsym!* eq !$eol!$ then go to delim else if null (x:= get(nxtsym!*,'switch!*)) then go to l else if eqcar(cdr x,'!*semicol!*) then go to delim; bool := seprp crchar!*; sw1: nxtsym!* := token(); if null(ttype!* = 3) then go to sw2 else if nxtsym!* eq !$eof!$ then return filenderr() else if car x then go to sw3; sw2: cursym!*:=cadr x; bool := nil; if cursym!* eq '!*rpar!* then go to l2 else return cursym!*; sw3: if bool or null (y:= atsoc(nxtsym!*,car x)) then go to sw2; prin2x nxtsym!*; x := cdr y; if null car x and cadr x eq '!*Comment!* then progn(comment!* := read!-comment(),go to a); go to sw1; conditional: % The conditional expression used here must be written in Lisp form x := errorset(rread(), !*backtrace, nil); % errors in evaluation count as NIL if null errorp x and car x then go to a; x := nil; skipping: % I support nesting of conditional inclusion. if nxtsym!* eq '!#endif then if null x then go to a else x := cdr x else if nxtsym!* eq '!#if then x := nil . x else if (nxtsym!* eq '!#else) and null x then go to a else if (nxtsym!* eq '!#elif) and null x then go to conditional; nxtsym!* := token(); if (ttype!*=3) and (nxtsym!* eq !$eof!$) then return filenderr() else go to skipping; comm: if delcp crchar!* and null(crchar!* eq !$eol!$) then progn(crchar!* := '! , condterpri(), go to a); crchar!* := readch(); go to comm; delim: semic!*:=nxtsym!*; return (cursym!*:='!*semicol!*); new: nxtsym!* := x; if stringp x then go to l else if atom x then go to c else go to l; q1: if null (car nxtsym!* eq 'string) then go to l; prin2x " "; prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*); l: cursym!*:=nxtsym!*; nxtsym!* := token(); if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr(); l2: if numberp nxtsym!* or (atom nxtsym!* and null get(nxtsym!*,'switch!*)) then prin2x " "; return cursym!* end; endmodule; module xread; % Routines for parsing RLISP input. % Author: Anthony C. Hearn. % Copyright (c) 1991 The RAND Corporation. All rights reserved. fluid '(!*blockp !*eoldelimp); % !*ignoreeol global '(cursym!* nxtsym!*); % The conversion of an RLISP expression to LISP prefix form is carried % out by the function XREAD. This function initiates the scanning % process, and then calls the auxiliary function XREAD1 to perform the % actual parsing. Both XREAD and XREAD1 are used by many functions % whenever an expression must be read; flag ('(end !*colon!* !*semicol!*),'delim); symbolic procedure chknewnam u; % Check to see if U has a newnam, and return it else return U. begin scalar x; return if null(x := get(u,'newnam)) or x eq u then u else if idp x then chknewnam x else x end; symbolic procedure mkvar(u,v); u; symbolic procedure remcomma u; if eqcar(u,'!*comma!*) then cdr u else list u; symbolic procedure eolcheck; if null !*eoldelimp then nil else begin a: if nxtsym!* eq !$eol!$ then progn(nxtsym!* := (if cursym!* eq 'end then '!; else token()), go to a) end; symbolic procedure xread1 u; begin scalar v,w,x,y,z,z1,z2; % This is the basic function for parsing RLISP input, once % tokens have been read by TOKEN and SCAN. Its one argument % U can take a number of values: % FOR: Parsing of FOR statements % GROUP: Parsing of group statements after keyword << % LAMBDA: Parsing of lambda expressions after keyword lambda % NIL: Parsing of expressions which can have a comma at % the end for example. % PROC: Parsing of procedures after keyword PROCEDURE % T: Default case with standard parsing. % Also, if U is flagged STRUCT, it is assumed that the arguments % are lists of lists, and so commas are removed. At present, % only MAT is tagged in this manner. % The local variables are used as follows: % v: expression being built % w: prefix operator stack % x: infix operator stack % y: infix value or stat property % z: current symbol % z1: next symbol % z2: temporary storage; a: z := cursym!*; a1: if null idp z then nil else if z eq '!*lpar!* then go to lparen else if z eq '!*rpar!* then go to rparen else if y := get(z,'infix) then go to infx % The next line now commented out was intended to allow a STAT % to be used as a label. However, it prevents the definition of % a diphthong whose first character is a colon. % else if nxtsym!* eq '!: then nil else if flagp(z,'delim) then go to delimit else if y := get(z,'stat) then go to stat else if flagp(z,'type) then progn(w := lispapply('decstat,nil) . w, go to a); a2: y := nil; a3: w := z . w; % allow for implicit * after a number. if toknump z and null(z1 eq !$eol!$) and idp (z1 := chknewnam nxtsym!*) and null flagp(z1,'delim) and null(get(z1,'switch!*) and null(z1 eq '!()) and null get(z1,'infix) and null (!*eoldelimp and z1 eq !$eol!$) then progn(cursym!* := 'times, go to a) else if u eq 'proc and length w > 2 then symerr("Syntax error in procedure header",nil); next: z := scan(); go to a1; lparen: eolcheck(); y := nil; if scan() eq '!*rpar!* then go to lp1 % no args else if flagpcar(w,'struct) then z := xread1 car w else z := xread1 'paren; if flagp(u,'struct) then progn(z := remcomma z, go to a3) else if null eqcar(z,'!*comma!*) then go to a3 else if null w % then go to a3 then (if u eq 'lambda then go to a3 else symerr("Improper delimiter",nil)) else w := (car w . cdr z) . cdr w; go to next; lp1: if w then w := list car w . cdr w; % Function of no args. go to next; rparen: if null u or u eq 'group or u eq 'proc then symerr("Too many right parentheses",nil) else go to end1; infx: eolcheck(); if z eq '!*comma!* or null atom (z1 := scan()) or toknump z1 then go to in1 else if z1 eq '!*rpar!* % Infix operator used as variable. or z1 eq '!*comma!* or flagp(z1,'delim) then go to in2 else if z1 eq '!*lpar!* % Infix operator in prefix position. and null eolcheck() % Side effect important and null atom(z1 := xread 'paren) and car z1 eq '!*comma!* and (z := z . cdr z1) then go to a1; in1: if w then go to unwind else if null(z := get(z,'unary)) then symerr("Redundant operator",nil); v := '!*!*un!*!* . v; go to pr1; % in2: if y then if !*ignoreeol then y := nil % else symerr("Redundant operator",nil); in2: if y then y := nil; w := z . w; in3: z := z1; go to a1; unwind: % Null w implies a delimiter was found, say, after a comma. if null w then symerr("Improper delimiter",nil); z2 := mkvar(car w,z); un1: w:= cdr w; if null w then go to un2 % Next line used to be toknump car w, but this test catches more % else if null idp car w and null eqcar(car w,'lambda) else if atom car w and null idp car w % and null eqcar(car w,'lambda) then symerr("Missing operator",nil); z2 := list(car w,z2); go to un1; un2: v:= z2 . v; preced: if null x then if y=0 then go to end2 else nil % else if z eq 'setq then nil % Makes parsing a + b := c more natural. else if y<caar x or (y=caar x and ((z eq cdar x and null flagp(z,'nary) and null flagp(z,'right)) or get(cdar x,'alt))) then go to pr2; pr1: x:= (y . z) . x; if null(z eq '!*comma!*) then go to in3 else if cdr x or null u or u memq '(lambda paren) or flagp(u,'struct) then go to next else go to end2; pr2: %if cdar x eq 'setq then go to assign else; % Check for NOT used as infix operator. if eqcar(cadr v,'not) and caar x >= get('member,'infix) then typerr("NOT","infix operator"); if cadr v eq '!*!*un!*!* then (if car v eq '!*!*un!*!* then go to pr1 else z2 := list(cdar x,car v)) else z2 := cdar x . if eqcar(car v,cdar x) and flagp(cdar x,'nary) then (cadr v . cdar v) else list(cadr v,car v); x:= cdr x; v := z2 . cddr v; go to preced; stat: if null(y eq 'endstat) then eolcheck(); if null(flagp(z,'go) or null(u eq 'proc) and (flagp(y,'endstatfn) or (null delcp nxtsym!* and null (nxtsym!* eq '!,)))) then go to a2; w := lispapply(y,nil) . w; y := nil; go to a; delimit: if null(cursym!* eq '!*semicol!*) then eolcheck(); if z eq '!*colon!* and null(u eq 'for) and (null !*blockp or null w or null atom car w or cdr w) or flagp(z,'nodel) and (null u or u eq 'group and null(z memq '(!*rsqbkt!* !*rcbkt!* !*rsqb!*))) then symerr("Improper delimiter",nil) else if idp u and (u eq 'paren or flagp(u,'struct)) then symerr("Too few right parentheses",nil); end1: if y then symerr("Improper delimiter",nil) % Probably ,). else if null v and null w and null x then return nil; y := 0; go to unwind; end2: if null cdr v then return car v else print "Please send hearn@rand.org your program!!"; symerr("Improper delimiter",nil) end; %symbolic procedure getels u; % getel(car u . !*evlis cdr u); %symbolic procedure !*evlis u; % mapcar(u,function lispeval); flag ('(endstat retstat),'endstatfn); flag ('(else then until),'nodel); flag ('(begin),'go); symbolic procedure xread u; begin a: scan(); if !*eoldelimp and cursym!* eq '!*semicol!* then go to a; return xread1 u end; symbolic procedure expread; xread t; flag('(expread xread),'opfn); % To make them operators. endmodule; module lpri; % Functions for printing diagnostic and error messages. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*defn !*echo !*fort !*int !*msg !*nat !*protfg); global '(cursym!* erfg!* ofl!* outl!*); symbolic procedure lpri u; begin a: if null u then return nil; prin2 car u; prin2 " "; u := cdr u; go to a end; symbolic procedure lpriw (u,v); begin scalar x; u := u . if v and atom v then list v else v; if ofl!* and (!*fort or not !*nat or !*defn) then go to c; terpri(); a: lpri u; terpri(); if null x then go to b; wrs cdr x; return nil; b: if null ofl!* then return nil; c: x := ofl!*; wrs nil; go to a end; symbolic procedure lprim u; !*msg and lpriw("***",u); symbolic procedure lprie u; begin scalar x; if !*int then go to a; x:= !*defn; !*defn := nil; a: erfg!* := t; lpriw ("*****",u); if null !*int then !*defn := x end; symbolic procedure printty u; begin scalar ofl; if null !*fort and !*nat then print u; if null ofl!* then return nil; ofl := ofl!*; wrs nil; print u; wrs cdr ofl end; symbolic procedure rerror(packagename,number,message); rederr message; symbolic procedure rederr u; begin if not !*protfg then lprie u; error1() end; symbolic procedure symerr(u,v); begin scalar x; erfg!* := t; if numberp cursym!* or not(x := get(cursym!*,'prtch)) then x := cursym!*; terpri(); if !*echo then terpri(); outl!* := reversip!*(car outl!* . '!$!$!$ . cdr outl!*); comm1 t; a: if null outl!* then go to b; prin2 car outl!*; outl!* := cdr outl!*; go to a; b: terpri(); if null v then rerror('rlisp,5,u) else rerror('rlisp,6, x . ("invalid" . (if u then list("in",u,"statement") else nil))) end; symbolic procedure typerr(u,v); rerror('rlisp,6,list(u,"invalid as",v)); endmodule; module parser; % Functions for parsing RLISP expressions. % Author: Anthony C. Hearn. % Copyright (c) 1991 The RAND Corporation. All rights reserved. fluid '(!*backtrace); global '(cursym!* letl!* nxtsym!*); %With the exception of assignment statements, which are handled by %XREAD, statements in REDUCE are introduced by a key-word, which %initiates a reading process peculiar to that statement. The key-word %is recognized (in XREAD1) by the indicator STAT on its property list. %The corresponding property is the name of the function (of no %arguments) which carries out the reading sequence. % ***** COMMENTS ***** symbolic procedure comm1 u; begin scalar bool; if u eq 'end then go to b; a: if cursym!* eq '!*semicol!* or u eq 'end and cursym!* memq '(end else then until !*rpar!* !*rsqbkt!*) then return nil else if u eq 'end and null bool then progn(lprim list("END-COMMENT NO LONGER SUPPORTED"), bool := t); b: scan(); go to a end; % ***** CONDITIONAL STATEMENT ***** symbolic procedure ifstat; begin scalar condx,condit; a: condx := xread t; if not(cursym!* eq 'then) then symerr('if,t); condit := aconc!*(condit,list(condx,xread t)); if not(cursym!* eq 'else) then nil else if scan() eq 'if then go to a else condit := aconc!*(condit,list(t,xread1 t)); return ('cond . condit) end; put('if,'stat,'ifstat); flag ('(then else),'delim); % ***** FUNCTION STATEMENT ***** symbolic procedure functionstat; begin scalar x; x := scan(); return list('function, if x eq '!*lpar!* then xread1 t else if idp x and null(x eq 'lambda) then progn(scan(),x) else symerr("Function",t)) end; put('function,'stat,'functionstat); % ***** LAMBDA STATEMENT ***** symbolic procedure lamstat; begin scalar x,y; x:= xread 'lambda; % x := flagtype(if null x then nil else remcomma x,'scalar); if x then x := remcomma x; y := list('lambda,x,xread t); % remtype x; return y end; put ('lambda,'stat,'lamstat); % ***** GROUP STATEMENT ***** symbolic procedure readprogn; %Expects a list of statements terminated by a >>; begin scalar lst; a: lst := aconc!*(lst,xread 'group); if null(cursym!* eq '!*rsqbkt!*) then go to a; scan(); return ('progn . lst) end; put('!*lsqbkt!*,'stat,'readprogn); flag('(!*rsqbkt!*),'delim); flag('(!*rsqbkt!*),'nodel); % ***** END STATEMENT ***** symbolic procedure endstat; %This procedure can also be used for any key-words which take no %arguments; begin scalar x; x := cursym!*; comm1 'end; return list x end; put('end,'stat,'endstat); put('endmodule,'stat,'endstat); put('bye,'stat,'endstat); put('quit,'stat,'endstat); flag('(bye quit),'eval); put('showtime,'stat,'endstat); endmodule; module block; % Block statement and related operators. % Author: Anthony C. Hearn. % Copyright (c) 1993 RAND. All rights reserved. fluid '(!*blockp !*rlisp88); global '(!*vars!* cursym!* nxtsym!*); % ***** GO statement ***** symbolic procedure gostat; begin scalar var; var := if eq(scan(),'to) then scan() else cursym!*; scan(); return list('go,var) end; put('go,'stat,'gostat); put('goto,'newnam,'go); % ***** Declaration Statement ***** symbolic procedure decl u; begin scalar varlis,w; a: if cursym!* eq '!*semicol!* then go to c else if not flagp(cursym!*,'type) then return varlis; % else if not(get(cursym!*,'stat) eq 'decstat) % then return varlis; % else if cursym!* eq 'dcl then go to dclr; w := cursym!*; if scan() eq 'procedure then return procstat1 w; varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w)); % b: if not(cursym!* eq '!*semicol!*) or null u then symerr(nil,t); if not(cursym!* eq '!*semicol!*) or null u then symerr(nil,t); c: scan(); go to a % dclr: varlis := append(varlis,dclstat1()); % go to b end; put('integer,'initvalue!*,0); symbolic procedure decstat; % Called if a declaration occurs at the top level or not first % in a block. begin scalar x,y,z; if !*blockp then symerr('block,t); x := cursym!*; y := nxtsym!*; z := decl nil; if y neq 'procedure then rerror('rlisp,7,list(x,"invalid outside block")); return z end; % put('integer,'stat,'decstat); % put('real,'stat,'decstat); % put('scalar,'stat,'decstat); flag('(integer real scalar),'type); symbolic procedure blocktyperr u; % Type declaration found at wrong position. rerror('rlisp,8,list(u,"invalid except at head of block")); % ***** Block Statement ***** symbolic procedure mapovercar u; begin scalar x; a: if u then progn(x := caar u . x, u := cdr u, go to a); return reversip!* x end; symbolic procedure blockstat; begin scalar hold,varlis,x,!*blockp; !*blockp := t; scan(); if cursym!* memq '(nil !*rpar!*) then rerror('rlisp,9,"BEGIN invalid"); varlis := decl t; a: if cursym!* eq 'end and not(nxtsym!* eq '!:) then go to b; x := xread1 nil; if eqcar(x,'end) then go to c; not(cursym!* eq 'end) and scan(); if x then hold := aconc!*(hold,x); go to a; b: comm1 'end; c: return mkblock(varlis,hold) end; symbolic procedure mkblock(u,v); 'rblock . (u . v); putd('rblock,'macro, '(lambda (u) (cons 'prog (cons (mapovercar (cadr u)) (cddr u))))); symbolic procedure symbvarlst(vars,body,mode); begin scalar x,y; if null(mode eq 'symbolic) then return nil; y := vars; a: if null y then return nil; x := if pairp car y then caar y else car y; if not fluidp x and not globalp x and not smemq(x,body) then lprim list("local variable",x,"in procedure", fname!*,"not used"); y := cdr y; go to a end; symbolic procedure formblock(u,vars,mode); progn(symbvarlst(cadr u,cddr u,mode), 'prog . append(initprogvars cadr u, formprog1(cddr u,append(cadr u,vars),mode))); symbolic procedure initprogvars u; begin scalar x,y,z; a: if null u then return(reversip!* x . reversip!* y) else if (z := get(caar u,'initvalue!*)) or (z := get(cdar u,'initvalue!*)) then y := mksetq(caar u,z) . y; x := caar u . x; u := cdr u; go to a end; symbolic procedure formprog(u,vars,mode); 'prog . cadr u . formprog1(cddr u,pairvars(cadr u,vars,mode),mode); symbolic procedure formprog1(u,vars,mode); if null u then nil else if null car u then formprog1(cdr u,vars,mode) % remove spurious NILs, probably generated by FOR statements. else if atom car u then car u . formprog1(cdr u,vars,mode) else if idp caar u and flagp(caar u,'modefn) then if !*rlisp88 and null(caar u eq 'symbolic) then typerr("algebraic expression","Rlisp88 form") else formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode) else formc(car u,vars,mode) . formprog1(cdr u,vars,mode); put('rblock,'formfn,'formblock); put('prog,'formfn,'formprog); put('begin,'stat,'blockstat); % ***** Return Statement ***** symbolic procedure retstat; if not !*blockp then symerr(nil,t) else begin scalar !*blockp; % To prevent RETURN within a RETURN. return list('return, if flagp(scan(),'delim) then nil else xread1 t) end; put('return,'stat,'retstat); endmodule; module form; % Performs a mode analysis of parsed forms. % Author: Anthony C. Hearn. % Modifications by: Jed Marti, Arthur C. Norman. % Copyright (c) 1993 RAND. All rights reserved. fluid '(!*!*a2sfn !*cref !*defn !*mode !*rlisp88 current!-modulus fname!* ftype!*); global '(!*argnochk !*composites !*force !*micro!-version !*vars!* cursym!*); !*!*a2sfn := 'aeval; flag('(algebraic symbolic),'modefn); symbolic procedure formcond(u,vars,mode); 'cond . formcond1(cdr u,vars,mode); symbolic procedure formcond1(u,vars,mode); if null u then nil else list(formbool(caar u,vars,mode),formc(cadar u,vars,mode)) % FORM1 here leaves out top level REVAL. . formcond1(cdr u,vars,mode); put('cond,'formfn,'formcond); symbolic procedure formlamb(u,vars,mode); list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode)); put('lambda,'formfn,'formlamb); symbolic procedure formprogn(u,vars,mode); 'progn . formclis(cdr u,vars,mode); put('progn,'formfn,'formprogn); symbolic procedure expdrmacro u; % Returns the macro form for U if expansion is permitted. begin scalar x; if null(x := getrmacro u) or flagp(u,'noexpand) then return nil % else if null(null !*cref and (null !*defn or car x eq 'smacro) % or flagp(u,'expand) or !*force) else if !*cref and null flagp(u,'expand) and null !*force then return nil else return x end; symbolic procedure getrmacro u; %returns a Reduce macro definition for U, if one exists, %in GETD format; begin scalar x; return if not idp u then nil else if (x := getd u) and car x eq 'macro then x else if (x := get(u,'smacro)) then 'smacro . x else nil end; symbolic procedure applmacro(u,v,w); apply1(u,w . v); put('macro,'macrofn,'applmacro); flag('(ed go quote),'noform); symbolic procedure set!-global!-mode u; begin !*mode := u; return list('null,list('setq,'!*mode,mkquote u)) end; symbolic procedure form1(u,vars,mode); begin scalar x,y; if atom u then return if not idp u then u else if u eq 'ed then list u else if flagp(u,'modefn) then set!-global!-mode u else if x:= get(mode,'idfn) then apply2(x,u,vars) else u else if not atom car u then return form2(u,vars,mode) else if not idp car u then typerr(car u,"operator") else if flagp(car u,'noform) then return u else if arrayp car u % and (mode eq 'symbolic or intexprlisp(cdr u,vars)) and mode eq 'symbolic then return list('getel,intargfn(u,vars,mode)) else if cdr u and (get(car u,'rtype) eq 'vector or vectorp cadr u or flagpcar(cadr u,'vecfn)) then return getvect(u,vars,mode) else if flagp(car u,'modefn) then return convertmode(cadr u,vars,mode,car u) else if (x := get(car u,'formfn)) then return macrochk(apply3(x,u,vars,mode),mode) else if get(car u,'stat) eq 'rlis then return macrochk(formrlis(u,vars,mode),mode) % else if (x := getd car u) and eqcar(x, 'macro) and % not(mode eq 'algebraic) then % return <<x := apply3(cdr x,u,vars,mode); % formc(x,vars,mode) >> % else if flagp(car u,'type) then blocktyperr car u else if car u eq '!*comma!* then if not atom cadr u and atom caddr u and flagp(caadr u,'type) % and(get(caddr u,'stat) eq 'decstat) then blocktyperr caadr u else rerror('rlisp,10, list("Syntax error: , invalid after",cadr u)); % Exclude algebraic operator with same name as symbolic function. if mode eq 'symbolic or flagp(car u,'opfn) then argnochk u; x := formlis(cdr u,vars,mode); y := if x=cdr u then u else car u . x; return if mode eq 'symbolic or get(car u,'stat) or cdr u and eqcar(cadr u,'quote) and null(!*micro!-version and null !*defn) or intexprnp(y,vars) and null !*composites and current!-modulus=1 then macrochk(y,mode) else if not(mode eq 'algebraic) then convertmode(y,vars,mode,'algebraic) else ('list . algid(car u,vars) . x) end; symbolic procedure form2(u,vars,mode); begin scalar x; if x := get(caar u,'form2fn) then return apply3(x,u,vars,mode) else typerr(car u,"operator") end; put('lambda,'form2fn,'formlis); symbolic procedure argnochk u; begin scalar x; if null !*argnochk then return u else if (x := argsofopr car u) and x neq length cdr u and null get(car u,'simpfn) then rerror('rlisp,11,list(car u,"called with", length cdr u, if length cdr u=1 then "argument" else "arguments", "instead of",x)) else return u end; symbolic procedure argsofopr u; % This function may be optimizable in various implementations. get(u,'number!-of!-args); symbolic procedure intexprnp(u,vars); %determines if U is an integer expression; if atom u then if numberp u then fixp u else if (u := atsoc(u,vars)) then cdr u eq 'integer else nil else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars); symbolic procedure intexprlisp(u,vars); null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars); flag('(difference minus plus times),'intfn); % EXPT is not included in this list, because a negative exponent can % cause problems (i.e., result can be rational); symbolic procedure formlis(u,vars,mode); begin scalar x; a: if null u then return reversip!* x; x := form1(car u,vars,mode) . x; u := cdr u; go to a end; symbolic procedure formclis(u,vars,mode); begin scalar x; a: if null u then return reversip!* x; x := formc(car u,vars,mode) . x; u := cdr u; go to a end; symbolic procedure form u; if null !*rlisp88 then form1(u,!*vars!*,!*mode) else if null(!*mode eq 'symbolic) or flagp(u,'modefn) and null(u eq 'symbolic) or flagpcar(u,'modefn) and null(car u eq 'symbolic) then typerr("algebraic expression","Rlisp88 form") else form1(u,!*vars!*,!*mode); symbolic procedure macrochk(u,mode); begin scalar y; % Expands U if CAR U is a macro and expansion allowed. % This model has the problem that nested macros are not expanded % at this point (but they will be in the compiler). if atom u then return u else if (y := expdrmacro car u) and (mode eq 'symbolic or idp car u and flagp(car u,'opfn)) then return apply3(get(car y,'macrofn),cdr y,cdr u,car u) else return u end; put('symbolic,'idfn,'symbid); symbolic procedure symbid(u,vars); <<if fname!* and null(ftype!* memq '(macro smacro)) and not(atsoc(u,vars) or fluidp u or globalp u or null u or u eq t or flagp(u,'share)) then lprim list("nonlocal use of undeclared variable",u, "in procedure",fname!*); u>>; put('algebraic,'idfn,'algid); symbolic procedure algid(u,vars); if atsoc(u,vars) or flagp(u,'share) then u else mkquote u; put('integer,'idfn,'intid); symbolic procedure intid(u,vars); begin scalar x,y; return if (x := atsoc(u,vars)) then if cdr x eq 'integer then u else if y := get(cdr x,'integer) then apply2(y,u,vars) else if cdr x eq 'scalar then !*!*a2i(u,vars) else rerror('rlisp,12, list(cdr x,"not convertable to INTEGER")) else !*!*a2i(mkquote u,vars) end; symbolic procedure convertmode(exprn,vars,target,source); convertmode1(form1(exprn,vars,source),vars,target,source); symbolic procedure convertmode1(exprn,vars,target,source); begin scalar x; if source eq 'real then source := 'algebraic; if target eq 'real then target := 'algebraic; if target eq source then return exprn else if idp exprn and (x := atsoc(exprn,vars)) and not(cdr x memq '(integer scalar real)) and not(cdr x eq source) then return convertmode(exprn,vars,target,cdr x) else if not (x := get(source,target)) then typerr(source,target) else return apply2(x,exprn,vars) end; put('algebraic,'symbolic,'!*!*a2s); put('symbolic,'algebraic,'!*!*s2a); symbolic procedure !*!*a2s(u,vars); % It would be nice if we could include the ATSOC(U,VARS) line, % since in many cases that would save recomputation. However, % in any sequential process, assignments or substitution rules % can change the value of a variable, so we have to check its % value again. More comprehensive analysis could certainly % optimize this. We could also avoid wrapping an integer, thus % making a mode change only occur within an expression. if null u or constantp u and null fixp u or intexprnp(u,vars) and null !*composites and null current!-modulus or flagpcar(u,'nochange) and not(car u eq 'getel) then u else list(!*!*a2sfn,u); symbolic procedure !*!*s2a(u,vars); u; symbolic procedure formc(u,vars,mode); %this needs to be generalized; if !*rlisp88 and flagpcar(u,'modefn) and null(car u eq 'symbolic) then typerr("algebraic expression","Rlisp88 form") else if mode eq 'algebraic and intexprnp(u,vars) then u else convertmode(u,vars,'symbolic,mode); symbolic procedure intargfn(u,vars,mode); % transforms array element U into expression with integer arguments. % Array name is treated as an algebraic variable; begin scalar x,y; y := cdr u; a: if y then progn(x := convertmode(car y,vars,'integer,mode) . x, y := cdr y, go to a); return 'list . form1(car u,vars,'algebraic) . reversip!* x end; put('algebraic,'integer,'!*!*a2i); symbolic procedure !*!*a2i(u,vars); if intexprnp(u,vars) then u else list('ieval,u); symbolic procedure ieval u; !*s2i reval u; flag('(ieval),'opfn); % To make it a symbolic operator. flag('(ieval),'nochange); put('symbolic,'integer,'!*!*s2i); symbolic procedure !*!*s2i(u,vars); if fixp u then u else list('!*s2i,u); symbolic procedure !*s2i u; if fixp u then u else typerr(u,"integer"); put('integer,'symbolic,'identity); symbolic procedure identity(u,vars); u; symbolic procedure formbool(u,vars,mode); if mode eq 'symbolic then formc(u,vars,mode) else if atom u then if u eq 't then u else if not idp u or atsoc(u,vars) then list('boolvalue!*,u) else list('boolvalue!*,formc!*(u,vars,mode)) else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u else if idp car u and get(car u,'boolfn) then get(car u,'boolfn) . formclis(cdr u,vars,mode) else if idp car u and flagp(car u,'boolean) then car u . formboollis(cdr u,vars,mode,flagp(car u,'boolargs)) else if car u eq 'boolvalue!* then rederr("Too many formbools") else if car u eq 'where then list('boolvalue!*, formc!*(list('where, mkquote list('bool!-eval,formbool(cadr u,vars,mode)), caddr u), vars,mode)) else list('boolvalue!*,formc!*(u,vars,mode)); symbolic procedure formboollis(u,vars,mode,bool); begin scalar x; a: if null u then return reversip!* x else if bool then x := formbool(car u,vars,mode) . x else x := formc!*(car u,vars,mode) . x; u := cdr u; go to a end; symbolic procedure bool!-eval u; lispeval u; flag('(bool!-eval),'noform); flag('(bool!-eval),'opfn); % symbolic operator bool!-eval. flag('(bool!-eval),'noval); symbolic procedure boolvalue!* u; u and null(u = 0); symbolic procedure formc!*(u,vars,mode); begin scalar !*!*a2sfn; !*!*a2sfn := 'reval; return formc(u,vars,mode) end; % Functions with side effects must be handled carefully in this model, % otherwise they are not always evaluated within blocks. symbolic procedure formrerror(u,vars,mode); begin scalar x; argnochk u; if not fixp caddr u then typerr(caddr u,"RERROR argument"); x := formc!*(cadddr u,vars,mode); if idp cadr u then return list('rerror,mkquote cadr u,caddr u,x) else if eqcar(cadr u,'quote) and idp cadadr u then return list('rerror,cadr u,caddr u,x) else typerr(cadr u,"RERROR argument") end; deflist('((rerror formrerror)),'formfn); % For bootstrapping. symbolic procedure formrederr(u,vars,mode); list('rederr,formc!*(cadr u,vars,mode)); put('rederr,'formfn,'formrederr); symbolic procedure formreturn(u,vars,mode); % begin scalar x; % x := form1(cadr u,vars,mode); % FORMC here would add REVAL % if not(mode memq '(symbolic integer real)) % and eqcar(x,'setq) % Should this be more general? % then x := list(!*!*a2sfn,x); % return list('return,x) % end; list('return,formc(cadr u,vars,mode)); put('return,'formfn,'formreturn); symbolic procedure rsverr x; rerror('rlisp,13,list (x,"is a reserved identifier")); symbolic procedure mksetshare(u,v); mksetq(u,list('progn,'(setq alglist!* (cons nil nil)),v)); symbolic procedure formsetq(u,vars,mode); begin scalar x,y,z; if idp(z := car(u := cdr u)) then y := atsoc(z,vars); if eqcar(cadr u,'quote) then mode := 'symbolic; % Make target always SYMBOLIC so that algebraic expressions % are evaluated before being stored. x := convertmode(cadr u,vars,'symbolic,mode); return if not atom z then if not idp car z then typerr(z,"assignment") else if null atom(z := macrochk(z,mode)) and arrayp car z then list('setel,intargfn(z,vars,mode),x) else if null atom z and cdr z and (get(car z,'rtype) eq 'vector or vectorp cadr z or flagpcar(cadr z,'vecfn)) then putvect(u,vars,mode) else if eqcar(z,'part) then aconc('list . mkquote 'setpart!* . formlis(cdr z,vars,mode),x) else if null atom z and (y := get(car z,'setqfn)) then form1(applsmacro(y,append(cdr z,cdr u),nil),vars,mode) else if mode eq 'symbolic and (!*rlisp88 or eqcar(z,'structfetch)) % Allow for Rlisp '88 records in general Rlisp. then list('rsetf,form1(z,vars,mode),x) else list('setk,form1(z,vars,'algebraic),x) % algebraic needed above, since SETK expects it. else if not idp z then typerr(z,"assignment") else if flagp(z,'reserved) and null atsoc(z,vars) then rsverr z else if flagp(z,'share) then mksetshare(symbid(z,vars),x) else if mode eq 'symbolic or y or eqcar(x,'quote) then mksetq(symbid(z,vars),x) else if vectorp cadr u or flagpcar(cadr u,'vecfn) then list('setv,mkquote z,cadr u) else list('setk,mkquote z,x) end; put('setq,'formfn,'formsetq); % Table of SETQFNs. symbolic procedure setcar(a,b); progn(rplaca(a,b),b); symbolic procedure setcdr(a,b); progn(rplacd(a,b),b); put('car,'setqfn,'(lambda (u v) (setcar u v))); put('cdr,'setqfn,'(lambda (u v) (setcdr u v))); put('caar,'setqfn,'(lambda (u v) (setcar (car u) v))); put('cadr,'setqfn,'(lambda (u v) (setcar (cdr u) v))); put('cdar,'setqfn,'(lambda (u v) (setcdr (car u) v))); put('cddr,'setqfn,'(lambda (u v) (setcdr (cdr u) v))); put('caaar,'setqfn,'(lambda (u v) (setcar (caar u) v))); put('caadr,'setqfn,'(lambda (u v) (setcar (cadr u) v))); put('cadar,'setqfn,'(lambda (u v) (setcar (cdar u) v))); put('caddr,'setqfn,'(lambda (u v) (setcar (cddr u) v))); put('cdaar,'setqfn,'(lambda (u v) (setcdr (caar u) v))); put('cdadr,'setqfn,'(lambda (u v) (setcdr (cadr u) v))); put('cddar,'setqfn,'(lambda (u v) (setcdr (cdar u) v))); put('cdddr,'setqfn,'(lambda (u v) (setcdr (cddr u) v))); put('caaaar,'setqfn,'(lambda (u v) (setcar (caaar u) v))); put('caaadr,'setqfn,'(lambda (u v) (setcar (caadr u) v))); put('caadar,'setqfn,'(lambda (u v) (setcar (cadar u) v))); put('caaddr,'setqfn,'(lambda (u v) (setcar (caddr u) v))); put('cadaar,'setqfn,'(lambda (u v) (setcar (cdaar u) v))); put('cadadr,'setqfn,'(lambda (u v) (setcar (cdadr u) v))); put('caddar,'setqfn,'(lambda (u v) (setcar (cddar u) v))); put('cadddr,'setqfn,'(lambda (u v) (setcar (cdddr u) v))); put('cdaaar,'setqfn,'(lambda (u v) (setcdr (caaar u) v))); put('cdaadr,'setqfn,'(lambda (u v) (setcdr (caadr u) v))); put('cdadar,'setqfn,'(lambda (u v) (setcdr (cadar u) v))); put('cdaddr,'setqfn,'(lambda (u v) (setcdr (caddr u) v))); put('cddaar,'setqfn,'(lambda (u v) (setcdr (cdaar u) v))); put('cddadr,'setqfn,'(lambda (u v) (setcdr (cdadr u) v))); put('cdddar,'setqfn,'(lambda (u v) (setcdr (cddar u) v))); put('cddddr,'setqfn,'(lambda (u v) (setcdr (cdddr u) v))); put('nth,'setqfn,'(lambda (l i x) (setcar (pnth l i) x))); put('getv,'setqfn,'(lambda (v i x) (putv v i x))); put('igetv,'setqfn,'(lambda (v i x) (iputv v i x))); symbolic procedure formfunc(u,vars,mode); if idp cadr u then if getrmacro cadr u then rerror('rlisp,14,list("Macro",cadr u,"Used as Function")) else list('function,cadr u) else list('function,form1(cadr u,vars,mode)); put('function,'formfn,'formfunc); % RLIS is a parser function that reads a list of arguments and returns % this list as one argument. It needs to be defined in this module for % bootstrapping purposes since this definition only works with its form % function. symbolic procedure rlis; begin scalar x; x := cursym!*; return if flagp(scan(),'delim) then list(x,nil) else x . remcomma xread1 'lambda end; symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end; symbolic procedure rlistat u; begin a: if null u then return nil; put(car u,'stat,'rlis); u := cdr u; go to a end; rlistat '(flagop); symbolic procedure formrlis(u,vars,mode); if not flagp(car u,'flagop) then list(car u,'list . if car u eq 'share then (begin scalar x,y; y := cdr u; a: if null y then return reversip!* x; x := mkquote car y . x; y := cdr y; go to a end) else formlis(cdr u,vars,'algebraic)) else if not idlistp cdr u then typerr('!*comma!* . cdr u,"identifier list") else list('flag, 'list . formlis(cdr u,vars,'algebraic),mkquote car u); symbolic procedure mkarg(u,vars); % Returns the "unevaled" form of U. if null u or constantp u then u else if atom u then if atsoc(u,vars) then u else mkquote u else if car u memq '(quote !:dn!: !:int!:) then mkquote u else begin scalar x; a: if null u then return 'list . reversip!* x; x := mkarg(car u,vars) . x; u := cdr u; go to a end; % Form functions needed for number input. put('!:dn!:,'formfn,'dnform); % symbolic procedure dnform(u,vars,mode); % if mode eq 'symbolic % then compress nconc!*(explode cadr u,'!. . 'e . explode cddr u) % else progn(if !*adjprec then precmsg length explode abs cadr u, % mkquote(quote !:rd!: . cdr u)); symbolic procedure dnform(u,vars,mode); if mode eq 'symbolic then compress nconc!*(explode cadr u,'!. . 'e . explode cddr u) else progn(if !*adjprec then precmsg length explode abs cadr u, mkquote if cddr u >= 0 then decimal2internal(cadr u,cddr u) else u); put('!:int!:,'formfn,'intform); symbolic procedure intform(u,vars,mode); if mode eq 'symbolic then mkquote cadr u else progn(precmsg length explode abs cadr u, mkquote cadr u); endmodule; module proc; % Procedure statement. % Author: Anthony C. Hearn. % Copyright (c) 1991 RAND. All rights reserved. fluid '(!*nosmacros !*redeflg!* fname!* ftype!*); global '(!*argnochk !*comp !*lose !*micro!-version cursym!* erfg!* ftypes!*); fluid '(!*defn); !*lose := t; ftypes!* := '(expr fexpr macro); symbolic procedure mkprogn(u,v); if eqcar(v,'progn) then 'progn . u . cdr v else list('progn,u,v); symbolic procedure formproc(u,vars,mode); begin scalar body,fname!*,name,type,varlis,x,y; u := cdr u; name := fname!* := car u; if cadr u then mode := cadr u; % overwrite previous mode u := cddr u; type := ftype!* := car u; if flagp(name,'lose) and (!*lose or null !*defn) then return progn(lprim list(name, "not defined (LOSE flag)"), nil) else if !*redeflg!* and getd name then lprim list(name,"redefined"); varlis := cadr u; u := caddr u; x := if eqcar(u,'rblock) then cadr u else nil; y := pairxvars(varlis,x,vars,mode); if x then u := car u . rplaca!*(cdr u,cdr y); body:= form1(u,car y,mode); % FORMC here would add REVAL. if !*nosmacros and type eq 'smacro then type := 'expr; if not(type eq 'smacro) and get(name,'smacro) then lprim list("SMACRO",name,"redefined"); symbvarlst(varlis,body,mode); if type eq 'expr then body := list('de,name,varlis,body) else if type eq 'fexpr then body := list('df,name,varlis,body) else if type eq 'macro then body := list('dm,name,varlis,body) else if (x := get(type,'procfn)) then return apply3(x,name,varlis,body) else body := list('putc, mkquote name, mkquote type, mkquote list('lambda,varlis,body)); if not(mode eq 'symbolic) then body := mkprogn(list('flag,mkquote list name,mkquote 'opfn),body); if !*argnochk and type memq '(expr smacro) then body := mkprogn(list('put,mkquote name, mkquote 'number!-of!-args, length varlis), body); if !*defn and type memq '(fexpr macro smacro) then lispeval body; return if !*micro!-version and type memq '(fexpr macro smacro) then nil else body end; put('procedure,'formfn,'formproc); symbolic procedure pairxvars(u,v,vars,mode); %Pairs procedure variables and their modes, taking into account %the convention which allows a top level prog to change the mode %of such a variable; begin scalar x,y; a: if null u then return append(reversip!* x,vars) . v else if (y := atsoc(car u,v)) then <<v := delete(y,v); if not(cdr y eq 'scalar) then x := (car u . cdr y) . x else x := (car u . mode) . x>> else if null idp car u or get(car u,'infix) or get(car u,'stat) then symerr(list("Invalid parameter:",car u),nil) else x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure procstat1 mode; begin scalar bool,u,type,x,y,z; bool := erfg!*; if fname!* then go to b else if cursym!* eq 'procedure then type := 'expr else progn(type := cursym!*,scan()); if not(cursym!* eq 'procedure) then go to c; x := errorset!*('(xread (quote proc)),nil); if errorp x then go to a else if atom (x := car x) then x := list x; % No arguments. fname!* := car x; %function name; if idp fname!* % and not(type memq ftypes!*) then if null fname!* or (z := gettype fname!*) and not(z memq '(procedure operator)) then go to d else if not getd fname!* then flag(list fname!*,'fnc); % To prevent invalid use of function name in body. u := cdr x; y := u; % Variable list. if idlistp y then x := car x . y else lprie list(y,"invalid as parameter list"); a: if eof!*>0 then progn(cursym!* := '!*semicol!*, go to a1); z := errorset!*('(xread t),nil); if not errorp z then z := car z; % if not atom z and eqcar(car z,'!*comment!*) then z := cadr z; if null erfg!* then z:=list('procedure,car x,mode,type,y,z); a1: remflag(list fname!*,'fnc); fname!*:=nil; if erfg!* then progn(z := nil,if not bool then error1()); return z; b: bool := t; c: errorset!*('(symerr (quote procedure) t),nil); go to a; d: typerr(list(z,fname!*),"procedure"); go to a end; symbolic procedure procstat; procstat1 nil; deflist ('((procedure procstat) (expr procstat) (fexpr procstat) (emb procstat) (macro procstat) (smacro procstat)), 'stat); % Next line refers to bootstrapping process. if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat); deflist('((lisp symbolic)),'newnam); endmodule; module forstat; % Definition of REDUCE FOR loops. % Author: Anthony C. Hearn. % Copyright (c) 1993 The RAND Corporation. All rights reserved. fluid '(!*blockp !*fastfor); global '(cursym!* foractions!*); Comment the syntax of the FOR statement is as follows: {step i3 until} {i := i1 { } i2 } { { : } } for { } <action> <expr> { { in } } { each i { } <list> } { on } In all cases, the <expr> is evaluated algebraically within the scope of the current value of i. If <action> is DO, then nothing else happens. In other cases, <action> is a binary operator that causes a result to be built up and returned by FOR. In each case, the loop is initialized to a default value. The test for the end condition is made before any action is taken. The effect of the definition here is to replace all for loops by semantically equivalent blocks. As a result, none of the mapping functions are needed in REDUCE. To declare a set of actions, one says; foractions!* := '(do collect conc product sum); remflag(foractions!*,'delim); % For bootstrapping purposes. % To associate a binary function with an action, one says: deflist('((product times) (sum plus)),'bin); % And to give these an initial value in a loop: deflist('((product 1) (sum 0)),'initval); % NB: We need to reset for and let delims if an error occurs. It's % probably best to do this in the begin1 loop. % flag('(for),'nochange); symbolic procedure forstat; begin scalar !*blockp; return if scan() eq 'all then forallstat() else if cursym!* eq 'each then foreachstat() else forloop() end; put('for,'stat,'forstat); symbolic procedure forloop; begin scalar action,bool,incr,var,x; if flagp('step,'delim) then bool := t else flag('(step),'delim); x := errorset!*('(xread1 'for),t); if null bool then remflag('(step),'delim) else bool := nil; if errorp x then error1() else x := car x; if not eqcar(x,'setq) or not idp(var := cadr x) then symerr('for,t); x := caddr x; if cursym!* eq 'step then <<if flagp('until,'delim) then bool := t else flag('(until),'delim); incr := xread t; if null bool then remflag('(until),'delim) else bool := nil; if not(cursym!* eq 'until) then symerr('for,t)>> else if cursym!* eq '!*colon!* then incr := 1 else symerr('for,t); if flagp(car foractions!*,'delim) then bool := t % nested loop else flag(foractions!*,'delim); incr := list(x,incr,xread t); if null bool then remflag(foractions!*,'delim); if not((action := cursym!*) memq foractions!*) then symerr('for,t); return list('for,var,incr,action,xread t) end; symbolic procedure formfor(u,vars,mode); begin scalar action,algp,body,endval,incr,initval,var,x; scalar !*!*a2sfn; % ALGP is used to determine if the loop calculation must be % done algebraically or not. !*!*a2sfn := 'aeval!*; var := cadr u; incr := caddr u; incr := list(formc(car incr,vars,mode), formc(cadr incr,vars,mode), formc(caddr incr,vars,mode)); if not atsoc(var,vars) then if intexprnp(car incr,vars) and intexprnp(cadr incr,vars) then vars := (var . 'integer) . vars else vars := (var . mode) . vars; action := cadddr u; body := formc(car cddddr u,vars,mode); initval := car incr; endval := caddr incr; incr := cadr incr; algp := algmodep initval or algmodep incr or algmodep endval; if algp then <<endval := unreval endval; incr := unreval incr>>; x := if algp then list('list,''difference,endval,var) else list(if !*fastfor then 'idifference else 'difference, endval,var); if incr neq 1 then x := if algp then list('list,''times,incr,x) else list('times,incr,x); % We could consider simplifying X here (via reval). x := if algp then list('aminusp!:,x) else list(if !*fastfor then 'iminusp else 'minusp,x); return forformat(action,body,initval,x, if algp then list('aeval!*,list('list,''plus,incr)) else list(if !*fastfor then 'iplus2 else 'plus2, incr), var,vars,mode) end; put('for,'formfn,'formfor); symbolic procedure algmodep u; not atom u and car u memq '(aeval aeval!*); symbolic procedure aminusp!: u; begin scalar x; u := aeval!* u; x := u; if fixp x then return minusp x else if not eqcar(x,'!*sq) then msgpri(nil,reval u,"invalid in FOR statement",nil,t); x := cadr x; if fixp car x and fixp cdr x then return minusp car x else if not(cdr x = 1) or not (atom(x := car x) or atom car x) % Should be DOMAINP, but SMACROs not yet defined. then msgpri(nil,reval u,"invalid in FOR statement",nil,t) else return apply1('!:minusp,x) end; symbolic procedure foreachstat; begin scalar w,x,y,z; if not idp(x := scan()) or not((y := scan()) memq '(in on)) then symerr("FOR EACH",t) else if flagp(car foractions!*,'delim) then w := t else flag(foractions!*,'delim); z := xread t; if null w then remflag(foractions!*,'delim); w := cursym!*; if not(w memq foractions!*) then symerr("FOR EACH",t); return list('foreach,x,y,z,w,xread t) end; put('foreach,'stat,'foreachstat); symbolic procedure formforeach(u,vars,mode); begin scalar action,body,lst,mod1,var; var := cadr u; u := cddr u; mod1 := car u; u := cdr u; lst := formc(car u,vars,mode); u := cdr u; if not(mode eq 'symbolic) then lst := list('getrlist,lst); action := car u; u := cdr u; body := formc(car u,(var . mode) . vars,mode); % was FORMC if mod1 eq 'in then body := list(list('lambda,list var,body),list('car,var)) else if not(mode eq 'symbolic) then typerr(mod1,'action); return forformat(action,body,lst, list('null,var),list 'cdr,var,vars,mode) end; put('foreach,'formfn,'formforeach); symbolic procedure forformat(action,body,initval, testexp,updform,var,vars,mode); begin scalar result; % Next test is to correct structure generated by formfor. if algmodep updform and length cadr updform > 2 then <<result:=gensym(); updform:= list list('lambda, list result, list('aeval!*, caadr updform . cadadr updform . result . cddadr updform))>>; result := gensym(); return sublis(list('body2 . if mode eq 'symbolic or intexprnp(body,vars) then list(get(action,'bin),body,result) else list('aeval!*,list('list,mkquote get(action,'bin), unreval body,result)), 'body3 . if mode eq 'symbolic then body else list('getrlist,body), 'body . body, 'initval . initval, 'nillist . if mode eq 'symbolic then nil else '(makelist nil), 'result . result, 'initresult . get(action,'initval), 'resultlist . if mode eq 'symbolic then result else list('cons,''list,result), 'testexp . testexp, 'updfn . car updform, 'updval . cdr updform, 'var . var), if action eq 'do then '(prog (var) (setq var initval) lab (cond (testexp (return nil))) body (setq var (updfn var . updval)) (go lab)) else if action eq 'collect then '(prog (var result endptr) (setq var initval) (cond (testexp (return nillist))) (setq result (setq endptr (cons body nil))) looplabel (setq var (updfn var . updval)) (cond (testexp (return resultlist))) (rplacd endptr (cons body nil)) (setq endptr (cdr endptr)) (go looplabel)) else if action eq 'conc then '(prog (var result endptr) (setq var initval) startover (cond (testexp (return nillist))) (setq result body) (setq endptr (lastpair resultlist)) (setq var (updfn var . updval)) (cond ((atom endptr) (go startover))) looplabel (cond (testexp (return result))) (rplacd endptr body3) (setq endptr (lastpair endptr)) (setq var (updfn var . updval)) (go looplabel)) else '(prog (var result) (setq var initval) (setq result initresult) lab1 (cond (testexp (return result))) (setq result body2) (setq var (updfn var . updval)) (go lab1))) end; symbolic procedure lastpair u; % Return the last pair of the list u. if atom u or atom cdr u then u else lastpair cdr u; symbolic procedure unreval u; % Remove spurious aeval or reval in inner expression. if atom u or null(car u memq '(aeval reval)) then u else cadr u; remprop('conc,'newnam); put('join,'newnam,'conc); % alternative for CONC endmodule; module loops; % Looping forms other than the FOR statement. % Author: Anthony C. Hearn % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!*); % ***** REPEAT STATEMENT ***** symbolic procedure repeatstat; begin scalar !*blockp,body,bool; if flagp('until,'delim) then bool := t else flag('(until),'delim); body:= xread t; if not bool then remflag('(until),'delim); if not(cursym!* eq 'until) then symerr('repeat,t); return list('repeat,body,xread t); end; symbolic macro procedure repeat u; begin scalar body,bool,lab; body := cadr u; bool := caddr u; lab := gensym(); return mkprog(nil,list(lab,body, list('cond,list(list('not,bool),list('go,lab))))) end; put('repeat,'stat,'repeatstat); flag('(repeat),'nochange); symbolic procedure formrepeat(u,vars,mode); begin scalar !*!*a2sfn; !*!*a2sfn := 'aeval!*; return list('repeat,formc(cadr u,vars,mode), formbool(caddr u,vars,mode)) end; put('repeat,'formfn,'formrepeat); % ***** WHILE STATEMENT ***** symbolic procedure whilstat; begin scalar !*blockp,bool,bool2; if flagp('do,'delim) then bool2 := t else flag('(do),'delim); bool := xread t; if not bool2 then remflag('(do),'delim); if not(cursym!* eq 'do) then symerr('while,t); return list('while,bool,xread t) end; symbolic macro procedure while u; begin scalar body,bool,lab; bool := cadr u; body := caddr u; lab := gensym(); return mkprog(nil,list(lab,list('cond,list(list('not,bool), list('return,nil))),body,list('go,lab))) end; put('while,'stat,'whilstat); flag('(while),'nochange); symbolic procedure formwhile(u,vars,mode); begin scalar !*!*a2sfn; !*!*a2sfn := 'aeval!*; return list('while,formbool(cadr u,vars,mode), formc(caddr u,vars,mode)) end; put('while,'formfn,'formwhile); endmodule; module write; % Miscellaneous statement definitions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. % ***** DEFINE STATEMENT ***** remprop('define,'stat); symbolic procedure define u; for each x in u do if not eqcar(x,'equal) or not idp cadr x then typerr(x,"DEFINE declaration") else put(cadr x,'newnam,caddr x); deflist('((define rlis)),'stat); flag('(define),'eval); % ***** WRITE STATEMENT ***** symbolic procedure formwrite(u,vars,mode); begin scalar bool1,bool2,x,y,z; u := cdr u; bool1 := mode eq 'symbolic; while u do <<x := formc(car u,vars,mode); y := getsetvars x; z := (if bool1 then list('prin2,x) else list('assgnpri,x,if y then 'list . y else nil, if not cdr u then if not bool2 then ''only else ''last else if not bool2 then ''first else nil)) . z; bool2 := t; u := cdr u>>; if bool1 then z := nil . z; % Since PRIN2 returns its value. return if null z then nil else if null cdr z then car z else 'progn . reversip!* z end; put('write,'stat,'rlis); put('write,'formfn,'formwrite); % ECHOPR is similar to WRITE but, if switch TESTECHO is on, it echos an % offline print onto the screen, in either algebraic or symbolic mode. % Switch is not yet defined. flag('(testecho),'switch); put('echopr,'stat,'rlis); put('echopr,'formfn,'formechopr); symbolic procedure formechopr(u,vars,mode); (lambda x; list ('progn,x, list ('cond,list ('(and !*testecho ofl!*), list (list ('lambda,'(n), list ('progn,x,'(wrs n),nil)),'(wrs nil) ))) )) formwrite(u,vars,mode); endmodule; module smacro; % Support for SMACRO expansion. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure applsmacro(u,vals,name); % U is smacro body of form (lambda <varlist> <body>), VALS is % argument list, NAME is name of smacro. begin scalar body,remvars,varlist,w; varlist := cadr u; body := caddr u; if length varlist neq length vals then rerror(rlisp,15,list("Argument mismatch for SMACRO",name)); if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body) then return subla!-q(pair(varlist,vals),body) else if length varlist>1 then <<w := for each x in varlist collect (x . gensym()); body := subla!-q(w,body); varlist := for each x in w collect cdr x>>; for each x in vals do <<if no!-side!-effectp x or one!-entryp(car varlist,body) then body := subla!-q(list(car varlist . x),body) else remvars := aconc(remvars,car varlist . x); varlist := cdr varlist>>; if null remvars then return body else <<w := list('lambda, for each x in remvars collect car x, body) . for each x in remvars collect cdr x; % if not eqcar(cadr w,'setq) % then <<prin2 "*** smacro: "; print cdr w>>; return w>> end; symbolic procedure no!-side!-effectp u; if atom u then numberp u or idp u and not(fluidp u or globalp u) else if car u eq 'quote then t else if flagp(car u,'nosideeffects) then no!-side!-effect!-listp cdr u else nil; symbolic procedure no!-side!-effect!-listp u; null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u; flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons),'nosideeffects); symbolic procedure one!-entryp(u,v); % determines if id U occurs less than twice in V. if atom v then t else if smemq(u,car v) then if smemq(u,cdr v) then nil else one!-entryp(u,car v) else one!-entryp(u,cdr v); symbolic procedure one!-entry!-listp(u,v); null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v); symbolic procedure subla!-q(u,v); begin scalar x; if null u or null v then return v else if atom v then return if x:= atsoc(v,u) then cdr x else v else if car v eq 'quote then return v else return(subla!-q(u,car v) . subla!-q(u,cdr v)) end; put('smacro,'macrofn,'applsmacro); endmodule; module io; % Reduce functions for handling input and output of files. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*echo !*int semic!*); global '(contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!* techo!*); % symbolic procedure filep u; % % Returns T if u is the name of an existing file. % begin % if errorp(u := errorset!*(list('open,mkquote u,''input),nil)) % then return nil; % close car u; % return t % end; symbolic procedure file!-transform(u,v); % Performs a transformation on the file u. V is name of function % used for the transformation. begin scalar echo,ichan,oldichan,val; echo := !*echo; !*echo := nil; ichan := open(u,'input); oldichan := rds ichan; val := errorset!*(list v,t); !*echo := echo; close ichan; rds oldichan; if not errorp val then return car val end; symbolic procedure infile u; % Loads the single file u into REDUCE without echoing. begin scalar !*int; return file!-transform(u,function begin1) end; symbolic procedure in u; begin scalar echop; echop := null(semic!* eq '!$); % Record echo character from input. if null ifl!* then techo!* := !*echo; % Terminal echo status. for each fl in u do in1(fl,echop); if ipl!* then ifl!* := car ipl!* else ifl!* := nil; if ifl!* then curline!* := caddr ifl!* end; symbolic procedure in1(fl,echop); begin scalar chan,echo,ochan; echo := !*echo; % Save current echo status. chan := open(fl := mkfil fl,'input); ochan := rds chan; if assoc(fl,linelist!*) then nil; curline!* := 1; ifl!* := list(fl,chan,1); ipl!* := ifl!* . ipl!*; % Add to input file stack. !*echo := echop; begin1(); rds ochan; close chan; !*echo := echo; % Restore echo status. if null ipl!* and contl!* then return nil else if null ipl!* or null(fl eq caar ipl!*) then rederr list("FILE STACK CONFUSION",fl,ipl!*) else ipl!* := cdr ipl!* end; symbolic procedure out u; % U is a list of one file. begin integer n; scalar chan,fl,x; n := linelength nil; if null u then return nil else if car u eq 't then return <<wrs(ofl!* := nil); nil>>; fl := mkfil car u; if not (x := assoc(fl,opl!*)) then <<chan := open(fl,'output); if chan then <<ofl!*:= fl . chan; opl!*:= ofl!* . opl!*>>>> else ofl!* := x; wrs cdr ofl!*; linelength n end; symbolic procedure shut u; % U is a list of names of files to be shut. begin scalar fl1; for each fl in u do <<if fl1 := assoc((fl := mkfil fl),opl!*) then <<opl!* := delete(fl1,opl!*); if fl1=ofl!* then <<ofl!* := nil; wrs nil>>; close cdr fl1>> else if not (fl1 := assoc(fl,ipl!*)) then rerror(rlisp,26,list(fl,"not open")) else if fl1 neq ifl!* then <<close cadr fl1; ipl!* := delete(fl1,ipl!*)>> else rerror(rlisp,27, list("Cannot shut current input file",car fl1))>> end; deflist ('((in rlis) (out rlis) (shut rlis)),'stat); flag ('(in out shut),'eval); flag ('(in out shut),'ignore); endmodule; module infix; % Functions for introducing new infix operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(preclis!*); symbolic procedure forminfix(u,vars,mode); begin scalar x; if null(mode eq 'symbolic) then x := for each j in cdr u collect list('mkop,mkarg(j,vars)); u := list(car u,mkarg(cdr u,vars)); return if x then 'progn . aconc(x,u) else u end; put('infix,'formfn,'forminfix); symbolic procedure infix x; <<for each j in x do if not(j member preclis!*) then preclis!* := j . preclis!*; mkprec()>>; symbolic procedure precedence u; begin scalar x,y,z; preclis!* := delete(car u,preclis!*); y := cadr u; x := preclis!*; a: if null x then rerror(rlisp,16,list (y,"not found")) else if y eq car x then <<preclis!* := nconc!*(reversip!* z,car x . (car u . cdr x)); mkprec(); return nil>>; z := car x . z; x := cdr x; go to a end; deflist('((infix rlis) (precedence rlis)),'stat); flag('(infix precedence),'eval); endmodule; module switch; % Support for switches and ON and OFF statements. % Author: Anthony C. Hearn. % Copyright (c) 1991 The RAND Corporation. All rights reserved. global '(!*switchcheck switchlist!*); % No references to RPLAC-based functions in this module. symbolic procedure on u; for each j in u do on1 j; symbolic procedure off u; for each j in u do off1 j; symbolic procedure off1 u; onoff(u,nil); symbolic procedure on1 u; onoff(u,t); symbolic procedure onoff(u,bool); begin scalar x,y; if not idp u then typerr(u,"switch") else if not flagp(u,'switch) % then if !*switchcheck then rerror(rlisp,25,list(u,"not defined as switch")); % else lpriw("*****",list(u,"not defined as switch")); x := intern compress append(explode '!*,explode u); if !*switchcheck and lispeval x eq bool then return nil else if y := atsoc(bool,get(u,'simpfg)) then lispeval('progn . append(cdr y,list nil)); if bool and x eq '!*!r!a!i!s!e then x := '!*raise; % Special case. set(x,bool) end; symbolic procedure switch u; % Declare list u as switches. for each x in u do begin scalar y; if not idp x then typerr(x,"switch"); if not(x memq switchlist!*) then switchlist!* := x . switchlist!*; flag(list x,'switch); y := intern compress append(explode '!*,explode x); if not fluidp y and not globalp y then fluid list y end; deflist('((switch rlis)),'stat); % we use deflist since it's flagged % eval flag('(switch),'eval); put('off,'stat,'rlis); put('on,'stat,'rlis); flag ('(off on),'ignore); % Symbolic mode switches: switch backtrace,comp,defn,demo,echo,errcont,fastfor, % eoldelimp int,lessspace,msg,output,pret,quotenewnam,raise,time; put('eoldelimp,'simpfg,'((t (flag (list !$eol!$) 'delchar)) (nil (remflag (list !$eol!$) 'delchar)))); endmodule; module where; % Support for a where construct. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(fixedpreclis!*); symbolic procedure formwhere(u,vars,mode); begin scalar expn,equivs,y,z; expn := cadr u; equivs := remcomma caddr u; if not(mode eq 'symbolic) then return formc(list('whereexp,'list . equivs,expn),vars,mode); for each j in equivs do if not atom j and car j memq '(equal setq) then <<y := caddr j . y; z := cadr j . z>> else rerror(rlisp,17,list(j,"invalid in WHERE statement")); return formc(list('lambda,reversip z,expn) . reversip y,vars,mode) end; put('where,'formfn,'formwhere); fixedpreclis!* := 'where . fixedpreclis!*; % Where has a special place. mkprec(); endmodule; module list; % Define a list as a list of expressions in curly brackets. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(orig!* posn!*); global '(cursym!* simpcount!* simplimit!*); % Add to system table. put('list,'tag,'list); put('list,'rtypefn,'quotelist); symbolic procedure quotelist u; 'list; % Parsing interface. symbolic procedure xreadlist; % Expects a list of expressions enclosed by {, }. % Used to allow expressions separated by ; - treated these as progn. begin scalar cursym,delim,lst; if scan() eq '!*rcbkt!* then <<scan(); return list 'list>>; a: lst := aconc(lst,xread1 'group); cursym := cursym!*; if cursym eq '!*semicol!* then symerr("Syntax error: semicolon in list",nil) else if scan() eq '!*rcbkt!* and cursym eq '!*comma!* then symerr("Syntax error: invalid comma in list",nil); if cursym eq '!*rcbkt!* then return % if delim eq '!*semicol!* % then 'progn . lst else 'list . lst else if null delim then delim := cursym; % else if not(delim eq cursym) % then symerr("Syntax error: mixed , and ; in list",nil); go to a end; put('!*lcbkt!*,'stat,'xreadlist); newtok '((!{) !*lcbkt!*); newtok '((!}) !*rcbkt!*); flag('(!*rcbkt!*),'delim); flag('(!*rcbkt!*),'nodel); % Evaluation interface. put('list,'evfn,'listeval); put('list,'simpfn,'simpiden); % This is a little kludgey, but allows % things like dms2deg to work. symbolic procedure getrlist u; if eqcar(u,'list) then cdr u else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list"); symbolic procedure listeval(u,v); <<if (simpcount!* := simpcount!*+1)>simplimit!* then <<simpcount!* := 0; rerror(rlisp,18,"Simplification recursion too deep")>>; u := if atom u then listeval(if flagp(u,'share) then eval u else if x then cadr x else typerr(u,'list),v) where x=get(u,'avalue) else if car u eq 'list then makelist for each x in cdr u collect reval1(x,v) else ((if x then apply2(x,cdr u,v) else rerror(rlisp,19,"Illegal operation on lists")) where x = get(car u,'listfn)); simpcount!* := simpcount!* - 1; u>>; symbolic procedure makelist u; % Make a list out of elements in u. 'list . u; % Length interface. put('list,'lengthfn,'lengthcdr); symbolic procedure lengthcdr u; length cdr u; % Printing interface. put('list,'prifn,'listpri); symbolic procedure listpri l; % This definition is basically that of INPRINT, except that it % decides when to split at the comma by looking at the size of % the argument. begin scalar orig,split,u; u := l; l := cdr l; prin2!* get('!*lcbkt!*,'prtch); % Do it this way so table can change. orig := orig!*; orig!* := if posn!*<18 then posn!* else orig!*+3; if null l then go to b; split := treesizep(l,40); % 40 is arbitrary choice. a: maprint(negnumberchk car l,0); l := cdr l; if null l then go to b; oprin '!*comma!*; if split then terpri!* t; go to a; b: prin2!* get('!*rcbkt!*,'prtch); % terpri!* nil; orig!* := orig; return u end; symbolic procedure treesizep(u,n); % true if u has recursively more pairs than n. treesizep1(u,n)=0; symbolic procedure treesizep1(u,n); if atom u then n - 1 else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n) else 0; % Definitions of operations on lists. symbolic procedure listeval0 u; begin scalar v; if (simpcount!* := simpcount!*+1)>simplimit!* then <<simpcount!* := 0; rerror(rlisp,20,"Simplification recursion too deep")>>; if idp u then if flagp(u,'share) then u := listeval0 eval u else if (v := get(u,'avalue)) and cadr v neq u then u := listeval0 cadr v; simpcount!* := simpcount!* - 1; return u end; % First, second, third and rest are designed so that only the relevant % elements need be fully evaluated. symbolic smacro procedure rlistp u; eqcar(u,'list); symbolic procedure rfirst u; begin scalar x; u := car u; % if null(getrtype(x := listeval0 u) eq 'list) % and null(getrtype(x := aeval u) eq 'list) if not rlistp(x := listeval0 u) and not rlistp(x := aeval u) then typerr(u,"list"); if null cdr x then parterr(u,1) else return reval cadr x end; put('first,'psopfn,'rfirst); symbolic procedure parterr(u,v); msgpri("Expression",u,"does not have part",v,t); symbolic procedure rsecond u; begin scalar x; u := car u; if not rlistp(x := listeval0 u) and not rlistp(x := aeval u) then typerr(u,"list"); if null cdr x or null cddr x then parterr(u,2) else return reval caddr x end; put('second,'psopfn,'rsecond); symbolic procedure rthird u; begin scalar x; u := car u; if not rlistp(x := listeval0 u) and not rlistp(x := aeval u) then typerr(u,"list"); if null cdr x or null cddr x or null cdddr x then parterr(u,3) else return reval cadddr x end; put('third,'psopfn,'rthird); deflist('((first (lambda (x) 'yetunknowntype)) (second (lambda (x) 'yetunknowntype)) (third (lambda (x) 'yetunknowntype)) (part (lambda (x) 'yetunknowntype))), 'rtypefn); symbolic procedure rrest u; begin scalar x; argnochk('cdr . u); u := car u; if not rlistp(x := listeval0 u) and not rlistp(x := aeval u) then typerr(u,"list"); if null cdr x then typerr(u,"non-empty list") else return 'list . for each y in cddr x collect reval y end; put('rest,'psopfn,'rrest); deflist('((first 1) (second 1) (third 1) (rest 1)),'number!-of!-args); symbolic procedure rappend u; begin scalar x,y; argnochk('append . u); if null(getrtype(x := reval car u) eq 'list) then typerr(x,"list") else if null(getrtype(y := reval cadr u) eq 'list) then typerr(y,"list") else return 'list . append(cdr x,cdr y) end; put('append,'psopfn,'rappend); symbolic procedure rcons u; begin scalar x,y,z; argnochk('cons . u); if (y := getrtypeor(x := revlis u)) eq 'hvector then return if get('cons,'opmtch) and (z := opmtch('cons . x)) then reval z else prepsq subs2 simpdot x else if not(getrtype cadr x eq 'list) then typerr(x,"list") else return 'list . car x . cdadr x end; put('cons,'psopfn,'rcons); symbolic procedure rreverse u; <<argnochk ('reverse . u); if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list") else 'list . reverse cdr u>>; put('reverse,'psopfn,'rreverse); % Aggregate Property. symbolic procedure listmap(u,v); begin scalar x; x := cadr u; if null eqcar(x,'list) and null eqcar(x := reval1(x,v),'list) then typerr(cadr u,"list"); return 'list . for each j in cdr x collect reval1(car u . j . cddr u,v) end; put('list,'aggregatefn,'listmap); % Sorting. fluid '(sortfcn!*); symbolic procedure listsort u; begin scalar l,n,w; if length u neq 2 then goto err; l:=cdr listeval(car u,nil); sortfcn!*:=cadr u; if(w:=get(sortfcn!*,'boolfn)) then sortfcn!*:=w; if null getd sortfcn!* or (n:=get(sortfcn!*,'number!-of!-args)) and n neq 2 then goto err; return 'list.sort(l,w or function(lambda(x,y); boolvalue!* reval {sortfcn!*,mkquote x,mkquote y})); err: rederr "illegal call to list sort"; end; put('sort,'psopfn,'listsort); endmodule; module array; % Array statement. % Author: Anthony C. Hearn. % Modifications by: Nancy Kirkwood. % These definitions are very careful about bounds checking. Appropriate % optimizations in a given system might really speed things up. fluid '(!*rlisp88); global '(erfg!*); symbolic procedure getel u; % Returns the value of the array element U. getel1(cadr get(car u,'avalue),cdr u,get(car u,'dimension)); symbolic procedure getel1(u,v,dims); if length v neq length dims then rerror(rlisp,21,"Incorrect array reference") else if null v then u else if car v geq car dims then rerror(rlisp,22,"Array out of bounds") else getel1(getv(u,car v),cdr v,cdr dims); symbolic procedure setel(u,v); % Sets array element U to V and returns V. setel1(cadr get(car u,'avalue),cdr u,v,get(car u,'dimension)); symbolic procedure setel1(u,v,w,dims); if length v neq length dims then rerror(rlisp,22,"Incorrect array reference") else if car v geq car dims then rerror(rlisp,23,"Array out of bounds") else if null cdr v then putv(u,car v,w) else setel1(getv(u,car v),cdr v,w,cdr dims); symbolic procedure dimension u; get(u,'dimension); Comment further support for REDUCE arrays; symbolic procedure typechk(u,v); begin scalar x; if (x := gettype u) eq v or x eq 'parameter then lprim list(v,u,"redefined") else if x then typerr(list(x,u),v) end; symbolic procedure arrayfn(u,v); % U is the defining mode, V a list of lists, assumed syntactically % correct. ARRAYFN declares each element as an array unless a % semantic mismatch occurs. begin scalar y; for each x in v do <<typechk(car x,'array); y := add1lis for each z in cdr x collect lispeval z; if null erfg!* then <<put(car x,'rtype,'array); put(car x,'avalue,list('array,mkarray1(y,u))); put(car x,'dimension,y)>>>> end; flag('(arrayfn),'nochange); symbolic procedure add1lis u; if null u then nil else (car u+1) . add1lis cdr u; symbolic macro procedure mkarray u; if null !*rlisp88 then mkarray1(u,'algebraic) else list('mkar1,'list . cdr u); symbolic procedure mkarray1(u,v); % U is a list of positive integers representing array bounds, V % the defining mode. Value is an array structure. if null u then if v eq 'symbolic then nil else 0 else begin integer n; scalar x; n := car u - 1; x := mkvect n; for i:=0:n do putv(x,i,mkarray1(cdr u,v)); return x end; put('array,'stat,'rlis); flag ('(array arrayfn),'eval); symbolic procedure formarray(u,vars,mode); begin scalar x; x := cdr u; while x do <<if atom x then typerr(x,"Array List") else if atom car x or not idp caar x or not listp cdar x then typerr(car x,"Array declaration"); x := cdr x>>; u := for each z in cdr u collect intargfn(z,vars,mode); %ARRAY arguments must be returned as quoted structures; return list('arrayfn,mkquote mode,'list . u) end; put('array,'formfn,'formarray); put('array,'rtypefn,'arraychk); symbolic procedure arraychk u; % If arraychk receives NIL, it means that array name is being used % as an identifier. We no longer permit this. if null u then 'array else nil; % nil; put('array,'evfn,'arrayeval); symbolic procedure arrayeval(u,v); % Eventually we'll support this properly. if not atom u then rerror(rlisp,24,"Array arithmetic not defined") else u; put('array,'lengthfn,'arraylength); symbolic procedure arraylength u; 'list . get(u,'dimension); endmodule; module inter; % Functions for interactive support. % Author: Anthony C. Hearn. % Copyright (c) 1993 RAND. All rights reserved. fluid '(!*echo !*int); global '(!$eof!$ !$eol!$ !*lessspace cloc!* contl!* curline!* edit!* eof!* erfg!* flg!* ifl!* ipl!* key!* ofl!* opl!* techo!*); symbolic procedure pause; %Must appear at the top-most level; if null !*int then nil else if key!* eq 'pause then pause1 nil else %typerr('pause,"lower level command"); pause1 nil; % Allow at lower level for now. symbolic procedure pause1 bool; begin scalar x; if bool then if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?" then return <<contl!* := nil; if ofl!* then <<lprim list(car ofl!*,'shut); close cdr ofl!*; opl!* := delete(ofl!*,opl!*); ofl!* := nil>>; edit1(cloc!*,nil)>> else if flg!* then return (edit!* := nil); if null ifl!* or yesp "Cont?" then return nil; ifl!* := list(car ifl!*,cadr ifl!*,curline!*); if x := assoccar(car ifl!*,contl!*) then <<contl!* := delete(x,contl!*); close cadar x>>; contl!* := (ifl!* . cdr ipl!* . !*echo) . contl!*; ifl!* := ipl!* := nil; rds nil; !*echo := techo!* end; symbolic procedure assoccar(u,v); % Returns element of v in which caar of that element = u. if null v then nil else if u=caaar v then car v else assoccar(u,cdr v); symbolic procedure yesp u; begin scalar ifl,ofl,x,y; if ifl!* then <<ifl := ifl!* := list(car ifl!*,cadr ifl!*,curline!*); rds nil>>; if ofl!* then <<ofl:= ofl!*; wrs nil>>; if null !*lessspace then terpri(); if atom u then prin2 u else lpri u; prin2t " (Y or N)"; if null !*lessspace then terpri(); y := setpchar '!?; x := yesp1(); setpchar y; if ofl then wrs cdr ofl; if ifl then rds cadr ifl; cursym!* := '!*semicol!*; return x end; symbolic procedure yesp1; % Basic loop for reading response. begin scalar bool,x,y; a: x := readch(); if x eq !$eol!$ then go to a; % Assume an end-of-file means lost control and exit. if x eq !$eof!$ then eval '(bye) else if (y := x eq 'y) or x eq 'n then return y else if null bool then <<prin2t "TYPE Y OR N"; bool := t>>; go to a end; symbolic procedure cont; begin scalar fl,techo; if ifl!* then return nil % CONT only active from terminal. else if null contl!* then rerror(rlisp,28,"No file open"); fl := caar contl!*; ipl!* := fl . cadar contl!*; techo := cddar contl!*; contl!* := cdr contl!*; if car fl=caar ipl!* and cadr fl=cadar ipl!* then <<ifl!* := fl; if fl then <<rds cadr fl; curline!* := caddr fl>> else rds nil; !*echo := techo>> else <<eof!* := 1; lprim list(fl,"not open"); error1()>> end; deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat); flag ('(cont),'ignore); endmodule; end;