Artifact 5d9843295b216078aff83c46b78f3bf16ffd15181872d5bb297c7046b7fb779b:
- Executable file
r36/src/rlisp88.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: 57167) [annotate] [blame] [check-ins using] [more...]
module rlisp88; % Support for the RLISP '88 superset. % Author: Anthony C. Hearn. fluid '(!*minusliter !*mode !*oldminusliter !*rlisp88 forbinops!* oldmode!*); switch rlisp88; create!-package('(rlisp88 for88 loops88 bquote Comment rvector mstruct records inspector), '(rlisp)); symbolic procedure rlisp88_on; begin if !*rlisp88 then return nil; !*rlisp88 := t; !*oldminusliter := !*minusliter; !*minusliter := t; deflist('((module formmodule) (global formglobalfluid) (fluid formglobalfluid) (procedure nformproc)), 'formfn); remprop('join,'newnam); put('conc,'newnam,'join); put('oldwhen,'infix,get('when,'infix)); remprop('when,'infix); flag('(for),'nochange); % Check on this. deflist(forbinops!*,'bin); deflist('((for forstat88) (repeat repeatstat88) (while whilstat88)),'stat); deflist('((for formfor88) (repeat formrepeat88) (while formwhile88)),'formfn); copyd('for,'for88); copyd('oldrepeat!*,'repeat); remd 'repeat; copyd('repeat,'repeat88); copyd('oldwhile!*,'while); remd 'while; % To avoid messages. copyd('while,'while88); if not(!*mode eq 'symbolic) then <<oldmode!* := !*mode; !*mode := 'symbolic>>; % The following statements, and their colloraries in rlisp88_off, % reveal problems with the current REDUCE model; it cannot specify % attributes in algebraic mode that do not apply in symbolic mode. % The following are representative, and by no means exhaustive. remprop('array,'stat); remprop('index,'stat); remprop('def,'stat); remprop('array,'formfn); remprop('add,'number!-of!-args); remprop('add,'smacro) end; symbolic procedure rlisp88_off; begin if null !*rlisp88 then return nil else if null getd 'oldrepeat!* then rederr "Rlisp88 mode not set"; !*minusliter := !*oldminusliter; remprop('module,'formfn); remprop('global,'formfn); remprop('fluid,'formfn); put('procedure,'formfn,'formproc); remprop('conc,'newnam); put('join,'newnam,'conc); put('when,'infix,get('oldwhen,'infix)); remflag('(for),'nochange); for each x in '(append collect count join maximize minimize) do remprop(x,'bin); deflist('((product times2) (sum plus2)),'bin); deflist('((for forstat) (repeat repeatstat) (while whilstat)), 'stat); deflist('((for formfor) (repeat formrepeat) (while formwhile)), 'formfn); remd 'for; remd 'repeat; remd 'while; copyd('repeat,'oldrepeat!*); copyd('while,'oldwhile!*); remd 'oldrepeat!*; remd 'oldwhile!*; if oldmode!* then <<!*mode := oldmode!*; oldmode!* := nil>>; deflist('((array rlis) (def rlis) (index rlis)),'stat); put('array,'formfn,'formarray); put('add,'number!-of!-args,2); put('add,'smacro,'(lambda (u v) (cons u v))) end; put('rlisp88,'simpfg,'((t (rlisp88_on)) (nil (rlisp88_off)))); endmodule; module for88; % Definition of Rlisp88 FOR statement. % Author: Anthony C. Hearn. fluid '(!*fastfor binops!* loopdelimslist!*); global '(forkeywords!*); flag('(fastfor),'switch); % Since switch may not yet be defined. Comment The FOR statement defined here has a very rich syntax with many different options. The parsing and macro expansion are under the control of keywords that are activated during parsing once FOR has been read. The keywords are deactivated at the end of the FOR statement, enabling them to be used as regular ID's in other parts of the program. The next ID after FOR may define a different type of FOR loop. Such different loops are indicated by the presence of the ID in the list forloops!*; deflist('((all forallstat)),'forloops!*); Comment Keywords are defined by their presence in the global list FORKEYWORDS!*. For each keyword, a parsing construct is also defined under the indicator FOR-KEYWORD. The parsing phase of the analysis returns a form: (FOR (<keyword> . <expression>) ... (<keyword> . <expression>)); forkeywords!* := '(collect count do each every finally in initially join on product returns some step sum unless until when with maximize minimize); % Note: append used to be on the above list, but was removed since it % couldn't be distinguished from the function "append". remflag(forkeywords!*,'delim); % For bootstrapping purposes. Comment some of the keywords denote actions (e.g., PRODUCT, SUM) with which a binary function is associated. To associate such a function with an action, one says; forbinops!* := '((append append) (collect cons) (count plus2) (join nconc) (maximize max2!*) (minimize min2!*) (product times2) (sum plus2)); % NB: We need to reset FOR and LET delims if an error occurs. It's % probably best to do this in the begin1 loop. symbolic procedure forstat88; begin scalar !*blockp,x; if x := get(scan(),'forloops!*) then return lispapply(x,nil); loopdelimslist!* := forkeywords!* . loopdelimslist!*; flag(forkeywords!*,'delim); return 'for . if cursym!* neq 'each then progn(x := forfrag(), x . fortail()) else fortail() end; symbolic procedure forfrag; begin scalar incr,var,x; x := erroreval '(xread1 'for); if not eqcar(x,'setq) or not idp(var := cadr x) then symerr('for,t); x := caddr x; if cursym!* eq 'step then <<incr := erroreval '(xread t); if not(cursym!* eq 'until) then symerr('for,t)>> else if cursym!* eq '!*colon!* then incr := 1 else symerr('for,t); return list('incr,var,x,erroreval '(xread t),incr) % if numberp incr and incr>0 % then incr := list('from,var,x,erroreval '(xread t),incr) % else if eqcar(incr,'minus) and numberp cadr incr and cadr incr>0 % then incr := list('down,var,x,erroreval '(xread t),cadr incr) % else rederr list("Increment",incr,"not supported"); % return incr end; symbolic procedure erroreval u; begin scalar x; x := errorset!*(u,t); if errorp x then error1() else return car x end; symbolic procedure eachfrag; begin scalar x,y; if not idp(x := scan()) or not((y := scan()) memq '(in on)) then symerr("For each",t); return list(y,x,erroreval '(xread t)); end; symbolic procedure fortail; begin scalar x,y,z,z1; a: z1 := cursym!*; if z1 eq 'each then if not idp(x := scan()) or not((y := scan()) memq '(in on)) then symerr("FOR EACH",t) else <<z := list(y,x,erroreval '(xread t)) . z; go to a>> else if z1 eq 'with then z := (z1 . erroreval '(xread 'lambda)) . z else if z1 eq '!*semicol!* then symerr("FOR EACH",t) else z := (z1 . erroreval '(xread t)) . z; if cursym!* memq forkeywords!* then go to a; remflag(car loopdelimslist!*,'delim); loopdelimslist!* := cdr loopdelimslist!*; if loopdelimslist!* then flag(car loopdelimslist!*,'delim); return reversip z end; symbolic procedure formfor88(u,vars,mode); begin scalar x,y,z; u := z := cdr u; % First check for local vars. a: if null z then go to b; x := car z; if car x memq '(down from incr in on) then vars := (cadr x . 'scalar) . vars; if null(car x eq 'with) then progn(z := cdr z,go to a); x := remcomma cdr x; a0: if x then progn(y := (car x . 'scalar) . y, x := cdr x, go to a0); vars := nconc(reversip!* y,vars); z := cdr z; go to a; % Now do actual analysis. b: if null u then return 'for . reversip z; x := car u; if car x memq '(down from incr) % We could optimize this by recognizing integers. then z := (car x . cadr x . formclis(cddr x,vars,mode)) . z else if car x eq 'with then z := (car x . remcomma cdr x) . z else if car x memq '(in on) then z := (car x . list(cadr x,formc(caddr x,vars,mode))) . z else z := (car x . formc(cdr x,vars,mode)) . z; u := cdr u; go to b end; symbolic macro procedure for88 x; begin scalar lvars,init,init2,final,body,!$cond,rets,cur,!$when, !*maxminflag,next,!$label2,!$while,cx,iv,action,curvar, valuevar,y; x := cdr x; action := caar x; !$label2 := gensym(); loop: if null x then <<final := mkfn(final,'progn); next := mkfn(next,'progn); !$cond := mkfn(!$cond,'or); cur := mkfn(cur,'progn); body := mkfn(body,'progn); if !$while then !$while := forcond sublis(pair('(!$while final rets), list(mkfn(!$while,'or), final,rets)), '(!$while final (return rets))); if !$when then body := forcond list(!$when,body); if !*maxminflag then rets := list('null2zero,rets); return forprog(lvars . nconc(init, nconc(init2, sublis(pair('(final body !$cond rets cur next !$label !$label2 !$while), list(final,body,!$cond,rets,cur,next, gensym(),!$label2,!$while)), if final then '(!$label (cond (!$cond (progn final (return rets)))) cur !$while body !$label2 next (go !$label)) else '(!$label (cond (!$cond (return rets))) cur !$while body !$label2 next (go !$label))))))>>; cx := car x; if atom cx then rederr list(cx,"invalid in FOR form") % WITH tacks its variables onto the !$LVARS list else if car cx eq 'with then lvars := append(lvars,cdr cx) % INITIALLY takes its expressions and tacks them onto the list of % INIT. This will later be built into a PROGN. else if car cx eq 'initially then init := aconc(init,cdr cx) % FINALLY puts its expressions on the list of FINAL. % This becomes a PROGN that is created just before the RETURN. else if car cx eq 'finally then final := aconc(final,cdr cx) % ON else if car cx eq 'on then <<valuevar := cadr cx; lvars := valuevar . lvars; !$cond := list('null,valuevar) . !$cond; init := list('setq,valuevar,caddr cx) . init; if cdddr cx then next := list('setq,valuevar,cadddr x) . next else next := list('setq, valuevar,list('cdr,valuevar)) . next>> % IN else if car cx eq 'in then <<valuevar := gensym(); iv := cadr cx; lvars := valuevar . iv . lvars; init := list('setq,valuevar,caddr cx) . init; !$cond := list('null,valuevar) . !$cond; cur := list('setq,iv,list('car,valuevar)) . cur; if cdddr cx then next := list('setq,valuevar,list cadddr cx) . next else next := list('setq,valuevar,list('cdr,valuevar)) . next>> % INCR else if car cx eq 'incr then begin scalar incr,incrvar; valuevar := cadr cx; cx := cddr cx; lvars := valuevar . lvars; init := list('setq,valuevar,car cx) . init; incr := caddr cx; if numberp incr then nil % Assume positive? else if eqcar(incr,'minus) and numberp cadr incr then incr := - cadr incr else <<incrvar := gensym(); lvars := incrvar . lvars; init := list('setq,incrvar,incr) . init; incr := incrvar>>; !$cond := (if incrvar then list('cond,list(list('minusp,incr), list('lessp,valuevar,cadr cx)), list('t,list('greaterp,valuevar, cadr cx))) else if minusp incr then if !*fastfor then list('ilessp,valuevar,cadr cx) else list('lessp,valuevar,cadr cx) else if !*fastfor then list('igreaterp,valuevar,cadr cx) else list('greaterp,valuevar,cadr cx)) . !$cond; next := list('setq,valuevar, list(if incrvar or not !*fastfor then 'plus2 else 'iplus2, valuevar,incr)) . next end % SUM, PRODUCT etc. else if car cx memq '(sum product append join count collect maximize minimize) then <<curvar := gensym(); lvars := curvar . lvars; % Set up initial value for loop. if car cx eq 'product then init := aconc!*(init,list('setq,curvar,1)) else if car cx memq '(count sum) then init := aconc!*(init,list('setq,curvar,0)) else if car cx memq '(maximize minimize) then <<!*maxminflag := t; %y := list(list('setq,curvar,cdr cx), % list('go,!$label2)); if action eq 'in then y := list('setq,iv,list('car,valuevar)); % . y; if action memq '(in on) then y := list('cond,list(list('null,valuevar), '(return 0))) . y; nconc!*(init,y)>>; if car cx eq 'collect then rets := list('reversip,curvar) else rets := curvar; body := list('setq,curvar, list(get(car cx,'bin), if car cx memq '(append count join) then curvar else cdr cx, if car cx memq '(append join) then cdr cx else if car cx eq 'count then list('cond,list(cdr cx,1),'(t 0)) else curvar)) . body>> % RETURNS else if car cx eq 'returns then rets := cdr cx % DO else if car cx eq 'do then body := aconc(body,cdr cx) % WHEN else if car cx eq 'when then if !$when then symerr("Redundant WHEN or UNLESS in FOR statement", nil) else !$when := cdr cx % UNLESS else if car cx eq 'unless then if !$when then symerr("Redundant WHEN or UNLESS in FOR statement", nil) else !$when := list('not,cdr cx) % WHILE % else if car cx eq 'while % then !$while := append(!$while,list list('not,cdr cx)) % UNTIL else if car cx eq 'until then !$while := append(!$while,list cdr cx) % SOME else if car cx eq 'some then cur := append(cur, list list('cond,list(cdr cx,list('return,t)))) % EVERY else if car cx eq 'every then <<if not rets then rets := t; cur := append(cur, list list('cond,list(list('null,cdr cx), list('return,nil))))>> else rederr list(car cx,"invalid in FOR form"); x := cdr x; go to loop end; symbolic procedure forcond u; list('cond,list(car u,if cddr u then 'progn . cdr u else cadr u)); symbolic procedure forprog u; 'prog . fornilchk u; symbolic procedure fornilchk u; if null u then nil else if null car u then fornilchk cdr u else car u . fornilchk cdr u; symbolic procedure max2!*(u,v); if null v then u else max2(u,v); symbolic procedure min2!*(u,v); if null v then u else min2(u,v); symbolic procedure null2zero u; if null u then 0 else u; symbolic procedure mkfn(x,fn); if atom x then x else if length x>1 then fn . x else car x; endmodule; module loops88; % Rlisp88 looping forms other than the FOR statement. % Author: Anthony C. Hearn. fluid '(!*blockp loopdelimslist!*); global '(cursym!* repeatkeywords!* whilekeywords!*); % ***** REPEAT STATEMENT ***** repeatkeywords!* := '(finally initially returns until with); symbolic procedure repeatstat88; begin scalar body,!*blockp,x,y,z; loopdelimslist!* := repeatkeywords!* . loopdelimslist!*; flag(repeatkeywords!*,'delim); body := erroreval '(xread t); if not (cursym!* memq repeatkeywords!*) then symerr('repeat,t); a: x := cursym!*; y := erroreval if x eq 'with then '(xread 'lambda) else '(xread t); z := (x . y) . z; if cursym!* memq repeatkeywords!* then go to a; remflag(car loopdelimslist!*,'delim); loopdelimslist!* := cdr loopdelimslist!*; if loopdelimslist!* then flag(car loopdelimslist!*,'delim); return 'repeat . body . reversip z end; symbolic macro procedure repeat88 u; begin scalar body,lab,xwith; body := cadr u; u := cddr u; xwith := atsoc('with,u); return sublis(pair('(!$locals !$do !$rets !$inits !$fins !$bool !$label), list(if xwith then cdr xwith else nil, body, x!-car x!-cdr atsoc('returns,u), mkfn(x!-cdr atsoc('initially,u),'progn), mkfn(x!-cdr atsoc('finally,u),'progn), x!-car x!-cdr atsoc('until,u), gensym())), '(prog !$locals !$inits !$label !$do (cond (!$bool !$fins (return !$rets))) (go !$label))) end; symbolic procedure remcomma!* u; if null u then nil else remcomma cdr u; symbolic procedure x!-car u; if atom u then u else car u; symbolic procedure x!-cdr u; if null u then nil else list cdr u; % flag('(repeat),'nochange); symbolic procedure formrepeat88(u,vars,mode); begin scalar y,z; for each x in cddr u do if car x eq 'with then <<y := remcomma cdr x; vars := nconc(for each j in y collect j . 'scalar, vars); z := (car x . y) . z>> % else if car x eq 'until % then z := (car x . formbool(cdr x,vars,mode)) . z else z := (car x . formc(cdr x,vars,mode)) . z; return 'repeat . formc(cadr u,vars,mode) . reversip z end; % ***** WHILE STATEMENT ***** whilekeywords!* := '(collect do finally initially returns with); symbolic procedure whilstat88; begin scalar !*blockp,bool1,x,y,z; loopdelimslist!* := whilekeywords!* . loopdelimslist!*; flag(whilekeywords!*,'delim); bool1 := erroreval '(xread t); if not (cursym!* memq whilekeywords!*) then symerr('while,t); a: x := cursym!*; y := erroreval if x eq 'with then '(xread 'lambda) else '(xread t); z := (x . y) . z; if cursym!* memq whilekeywords!* then go to a; remflag(car loopdelimslist!*,'delim); loopdelimslist!* := cdr loopdelimslist!*; if loopdelimslist!* then flag(car loopdelimslist!*,'delim); return 'while . bool1 . reversip z end; symbolic macro procedure while88 u; begin scalar body,bool,lab,rets,vars; bool := cadr u; u := cddr u; rets := x!-car x!-cdr atsoc('returns,u); vars := x!-car x!-cdr atsoc('with,u); if body := atsoc('collect,u) then <<vars := gensym() . vars; body := list('setq, car vars, list('cons,cdr body,car vars)); if rets then rederr "While loop value conflict"; rets := list('reversip,car vars)>> else if body := atsoc('do,u) then body := cdr body else rederr "Missing body in WHILE statement"; return sublis(pair('(!$locals !$do !$rets !$inits !$fins !$bool !$label), list(vars, body, rets, mkfn(x!-cdr atsoc('initially,u),'progn), mkfn(x!-cdr atsoc('finally,u),'progn), bool, gensym())), '(prog !$locals !$inits !$label (cond ((not !$bool) !$fins (return !$rets))) !$do (go !$label))) end; % flag('(while),'nochange); symbolic procedure formwhile88(u,vars,mode); begin scalar y,z; for each x in cddr u do if car x eq 'with then <<y := remcomma cdr x; vars := nconc(for each j in y collect j . 'scalar, vars); z := (car x . y) . z>> else z := (car x . formc(cdr x,vars,mode)) . z; return 'while . formc(cadr u,vars,mode) . reversip z end; endmodule; module bquote; % Support for backquote. % Author: Anthony C. Hearn. % Copyright (c) 1993 The RAND Corporation. All rights reserved. % Lisp parsing case. symbolic procedure tokbquote; begin crchar!* := readch1(); nxtsym!* := list('backq,rread()); ttype!* := 3; return nxtsym!* end; put('!`,'tokprop,'tokbquote); put('backq,'formfn,'formbquote); symbolic procedure formbquote(u,vars,mode); mkbquote cadr u; symbolic procedure mkbquote u; % Returns the "unevaled" form of u. if null u or constantp u then u else if atom u then mkquote u else if car u eq 'quote then if cadr u eq '!# then rederr "Invalid use of # after '" else mkquote u else if car u eq 'listify then mkbquote cdr u else if car u eq '!# then if eqcar(cdr u,'!@) then if null cdddr u then caddr u else list('append,caddr u,mkbquote cdddr u) else list('cons,cadr u,mkbquote cddr u) else if car u eq '!@ then rederr "Invalid use of @" else list('cons,mkbquote car u,mkbquote cdr u); % Rlisp parsing case. put('backquote,'stat,'bquotstat); symbolic procedure bquotstat; list('backquote,rl2l cadr rlis()); symbolic procedure rl2l u; if atom u then u else if atom car u then car u . rl2l cdr u else if caar u eq 'hash or caar u eq '!# then if eqcar(cadar u,'!@) then '!# . '!@ . cadr cadar u . rl2l cdr u else '!# . cadar u . rl2l cdr u else rl2l car u . rl2l cdr u; put('backquote,'formfn,'formbquote); endmodule; module Comment; % Routines for handling active comments. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. % This module supports the concept of active comments. Such comments are % delimited by the comment brackets /* and */. Everything read between % those brackets is converted to a string (including eol), and the % expression returned as the list (*comment* <comment string>). symbolic procedure read!-Comment; begin scalar ollength,raise,x,y,z; raise := !*raise; !*raise := nil; ollength := linelength 150; z := list(crchar!*,'!"); a: if (x := readch()) eq '!* then if (y := readch()) eq '!/ then go to b else z := y . x . z else if x = !$eof!$ then <<!*raise := raise; rederr "EOF encountered in comment">> else z := x . z; go to a; b: !*raise := raise; crchar!* := readch(); z := '!" . z; z := list('!*Comment!*,mkstrng compress reversip z); linelength ollength; return z end; newtok '((!/ !*) !*Comment!*); endmodule; module rvector; % Definition of RLISP vectors and operations on them. % Author: Anthony C. Hearn. % Copyright (c) 1990 The RAND Corporation. All rights reserved. fluid '(!*fastvector); global '(cursym!*); switch fastvector; % Add to system table. flag('(vec!*),'vecfn); % Parsing interface. symbolic procedure xreadvec; % Expects a list of expressions enclosed by [, ]. begin scalar cursym,delim,lst; if scan() eq '!*rsqb!* then <<scan(); return list 'list>>; a: lst := aconc(lst,xread1 'group); cursym := cursym!*; scan(); if cursym eq '!*rsqb!* then return if delim eq '!*semicol!* then 'progn . lst else list('vec!*,'list . lst) else if null delim then delim := cursym else if not(delim eq cursym) then symerr("Syntax error: mixed , and ; in vector",nil); go to a end; put('!*lsqb!*,'stat,'xreadvec); newtok '((![) !*lsqb!*); newtok '((!]) !*rsqb!*); flag('(!*rsqb!*),'delim); flag('(!*rsqb!*),'nodel); symbolic procedure vec!* u; % Make a vector out of elements of u. begin scalar n,x; n := length u - 1; x := mkvect n; for i:= 0:n do <<putv(x,i,car u); u := cdr u>>; return x end; % Evaluation interface. % symbolic procedure setv(u,v); % <<set(u,v); put(u,'rtype,'vector); v>>; % Length interface. % Printing interface. % Definitions of operations on vectors. symbolic procedure getvect(u,vars,mode); expandgetv(symbid(car u,vars),formlis(evalvecarg cdr u,vars,mode)); symbolic procedure expandgetv(u,v); if null v then u else expandgetv(list(if !*fastvector then 'igetv else 'getv, u,car v), cdr v); symbolic procedure putvect(u,vars,mode); expandputv(symbid(caar u,vars),formlis(evalvecarg cdar u,vars,mode), form1(cadr u,vars,mode)); symbolic procedure expandputv(u,v,w); if null cdr v then list(if !*fastvector then 'iputv else 'putv,u,car v,w) else expandputv(list(if !*fastvector then 'igetv else 'getv, u,car v), cdr v,w); symbolic procedure evalvecarg u; % if u and null cdr u and vectorp car u % then for i:=0:upbv car u collect getv(car u,i) else if u and null cdr u and eqcar(car u,'vec!*) and eqcar(cadar u,'list) then cdadar u else u; % Support for arrays defined in terms of vectors. symbolic procedure mkar1 u; begin scalar x; x := mkvect car u; if cdr u then for i:= 0:upbv x do putv(x,i,mkar1 cdr u); return x end; symbolic macro procedure array u; % Create an array from the elements in u. list('vec!*,'list . cdr u); endmodule; module mstruct; % A tiny structure package for Standard Lisp. % Author: Bruce A. Florman. % Copyright (c) 1989, The RAND Corporation. All rights reserved. Comment DESCRIPTION (defstruct <structspec> [ <slotspec>... ] ) The <structspec> may be either the name of the structure, or a list containing the name followed by zero or more options. Each <slotspec> may be either a list containing the slot name and its default value, or simply the slot name, in which case the default value is NIL. Each option in the <structspec> may be either an option name, or a list containing the option name and a specified value. If only the option name is given, then the default value for the given option is used. If NIL is the specified value in an option, then the option is not used at all (in general a NIL value is the same as not having that option in the list at all). If the same option appears more than once with different values, the last one in the <structspec> takes precedence. These are the valid options: PREDICATE Makes the zeroth element of the structure contain the structure name and creates a predicate macro to test if a given item is an instance of this structure. The specified value is the name of the predicate macro. The default value is the structure name followed by a `P'. CONSTRUCTOR By default the name of the constructor macro is `MAKE-' followed by the structure name. You may provide a different constructor name with this option. If there is no constructor option in the <structspec> the default constructor will still be generated. The only way to completely suppress the generation of a constructor macro is to have a (CONSTRUCTOR NIL) option. The flag !*FASTSTRUCTS controls how the accessor macros expand. If it is NIL, they expand as GETVs, otherwise they expand as IGETVs. NOTE: see records.tst for a level 0 test file. REVISION HISTORY 07/19/85 BAF -- File created. 01/26/89 BAF -- Added predicate and constructor macros so that this code can replace the RLISP record code. Changed GetR to StructFetch, and !*FAST-RECORDS to !*FASTSTRUCTS. Added code to check the validity of the options. Also added this file header. 01/30/89 BAF -- Added CONC-NAME as a synonym for SLOT-PREFIX and the ExplodeId function for compatability with existing programs (eg. ernie). Wed Apr 21 14:22:18 1993 - JBM Convert to RLISP '88, remove prefix stuff. Tue May 11 09:03:20 1993 - JBM Remove tconc and fix evaluator bug. Mon May 17 15:36:54 1993 - JBM Add RSETF function. Tue May 18 11:09:07 1993 - JBM add qputv for CSL to RSETF; flag('(defstruct), 'eval); fluid '(!*faststructs); switch faststructs; macro procedure defstruct u; begin integer indx; scalar options,slot_forms,name,predicate,constructor,functions; options := get_defstruct_options cadr u; if cdr u then slot_forms := for each slot in cddr u collect if idp slot then {slot,nil} else slot; name := car options; predicate := atsoc('predicate,cdr options); if predicate then predicate := cdr predicate; constructor := atsoc('constructor,cdr options); if constructor then constructor := cdr constructor; functions := nil; if constructor then functions := build_defstruct_constructor_macro(name, constructor, slot_forms, predicate) . functions; if predicate then functions := build_defstruct_predicate_function(name, predicate) . functions; indx := if predicate then 1 else 0; for each slot in slot_forms do <<functions := build_defstruct_accessor_macro(car slot, indx) . functions; indx := indx + 1>>; functions := mkquote name . functions; return 'progn . reverse functions end; expr procedure get_defstruct_options u; begin scalar name, options, predicate, constructor; if pairp u then << name := car u; options := cdr u >> else << name := u; options := nil >>; if not idp name then error(0, {"bad defstruct name:", name}); for each entry in options do if entry eq 'predicate then predicate := intern compress append(explode name, '(p)) else if eqcar(entry, 'predicate) then predicate := cadr entry else if entry eq 'constructor then constructor := intern compress append('(m a k e !! !-), explode name) else if eqcar(entry,'constructor) then constructor := cadr entry else error(0, {"bad defstruct option:", entry}); if null constructor then constructor := intern compress append('(m a k e !! !-), explode name); return {name, 'predicate . predicate, 'constructor . constructor} end; expr procedure explodeid x; % EXPLODEID(X) - Explode whatever x is and make sure the result can % be compressed back into an id no matter what it is. if idp x then explode x else for each elt in explode2 x join {'!!, elt}; expr procedure build_defstruct_constructor_macro (name,macro_name,slot_forms,has_predicate); begin scalar dflts; dflts := for each x in slot_forms collect {'cons, mkquote car x, cadr x}; % I deal with the name field by inserting it as an extra slot, with % slot-name made by a gensym so that the user will not get to % override the default value ever. As coded here if the default % value of a slot depends on a variable called !$!$!$ then scope % issues will lead to silly results being generated. if has_predicate then dflts := {'cons, '(gensym), mkquote name} . dflts; return {'putd, mkquote macro_name, ''macro, mkquote {'lambda, '(!$!$!$), {'list, ''defstructvector, {'mklist, {'defstruct_constructor, '(cdr !$!$!$), 'list . dflts}}}}} end; symbolic procedure mklist x; 'list . x; expr procedure defstruct_constructor(u, dflts); for each d in dflts collect find_struct_key(car d, u, cdr d); expr procedure find_struct_key(key, u, dflt); if null u then mkquote dflt else if car u eq key then if null cdr u then nil else cadr u else find_struct_key(key, cddr u, dflt); expr procedure defstructvector l; % DEFSTRUCTVECTOR(L) - Create a vector and store the list L into it. % This is a portable substitute for PSL's list2vector. begin integer i; scalar v; v := mkvect sub1 length l; i := 0; for each vl in l do <<putv(v,i,vl); i := i+1>>; return v end; expr procedure build_defstruct_predicate_function(name, fnname); % BUILD_DEFSTRUCT_PREDICATE_FUNCTION(NAME, FNNAME) - Builds a defstruct % predicate to return as a function. {'de, fnname, '(x), {'and, '(vectorp x), {'eq, mkquote name, '(igetv x 0)}}}; expr procedure build_defstruct_accessor_macro(slot_name,indx); {'dm, slot_name, '(u), {'list, '(quote structfetch), '(cadr u), indx}}; macro procedure structfetch u; if !*faststructs then 'igetv . cdr u else 'getv . cdr u; %----------------------------------------------------------------------- % SETF for RLISP88 %----------------------------------------------------------------------- macro procedure rsetf u; expandrsetf(cadr u, caddr u); expr procedure expandrsetf(lhs, rhs); if atom lhs then {'setq, lhs, rhs} else if eqcar(lhs, '!&variable_fetch) then '!&variable_store . append(cdr lhs, {rhs}) else if get(car lhs, 'assign_op) then get(car lhs, 'assign_op) . append(cdr lhs, {rhs}) else if getd car lhs and eqcar(getd car lhs, 'macro) then expandrsetf(apply(cdr getd car lhs, {lhs}), rhs) else error(0, {lhs, "bad RSETF form"}); deflist('((getv putv) (igetv putv) (car rplaca) (cdr rplacd)), 'assign_op); % This is CSL specific but shouldn't hurt anybody. put('qgetv, 'assign_op, 'qputv); endmodule; module records; % A record package for RLISP using MSTRUCT. % Author: Bruce Florman. % Copyright: (c) 1989 The RAND Corporation. All rights reserved. % Revision History: % 01/26/89 BAF -- Added this file header. % Sat Apr 24 12:38:32 1993 - Remove non-RLISP'88 functions (first, % etc.). % BothTimes Load MSTRUCT; %----------------------------------------------------------------------- % RECORD Declaration %----------------------------------------------------------------------- expr procedure recordstat(); % RECORD <struct-name> % { /* <annotation> */ } % { WITH <field> := <expression> { , <field> := <expression> }... } % { HAS <option> { , <option> }... } ; begin scalar f, stat; f := flagp('has,'delim); flag('(has),'delim); stat := errorset('(recordstat1),nil,nil); if not f then remflag('(has),'delim); if errorp stat then while cursym!* neq '!*semicol!* do scan() else return car stat end; expr procedure recordstat1(); begin scalar structname, annotation, fields, options; structname := scan(); if not idp structname then symerr('record, t); if eqcar(scan(), '!*Comment!*) then <<annotation := cadr cursym!*; scan()>>; if cursym!* eq 'with then fields := remcomma xread nil; if cursym!* eq 'has then options := remcomma xread nil; if cursym!* eq '!*semicol!* then return {'record, structname, annotation, fields, options} else symerr('record, t) end; put('record,'stat,'recordstat); expr procedure formrecord(u, vars, mode); apply(form_function, cdr u) where form_function = function(lambda(record_name, annotation, fields, options); begin scalar structspec, fieldspecs, constructor, form; structspec := form_structure_specification(record_name, options); fieldspecs := form_field_specifications(fields); constructor := cdr atsoc('constructor, get_defstruct_options structspec); form := {nil}; tconc(form, 'progn); if constructor then << tconc(form, {'put, mkquote constructor, '(quote formfn), '(quote form_record_constructor)}); put(constructor, 'formfn, 'form_record_constructor) >>; if annotation then tconc(form, {'put, mkquote record_name, '(quote annotation), annotation}); tconc(form, 'defstruct . structspec . fieldspecs); return car form end); put('record, 'formfn, 'formrecord); expr procedure tconc(ptr,elem); % ACONC with pointer to end of list. Ptr is (list . last CDR of % list). Returns updated Ptr. Ptr should be initialized to % (NIL . NIL) before calling the first time. <<elem := list elem; if not pairp ptr then elem . elem else if null cdr ptr then rplaca(rplacd(ptr,elem),elem) else <<rplacd(cdr ptr,elem); rplacd(ptr,elem)>>>>; expr procedure form_structure_specification(record_name, options); append(defaults, for each entry in options collect if atom entry then entry else if eqcar(entry, 'no) and length entry=2 then {cadr entry, nil} else if car entry eq 'equal and length entry=3 then {cadr entry, caddr entry} else error(0, {"Bad RECORD option:", entry})) where defaults = {record_name,{'constructor, record_name}, 'predicate}; expr procedure form_field_specifications field_list; for each entry in field_list join if eqcar(entry, 'setq) then {{cadr(entry), form1(caddr entry, nil, 'symbolic)}} else nil; expr procedure form_record_constructor(u, vars, mode); begin scalar constructor, arglist; constructor := car u; arglist := {nil}; for each arg in cdr u do if eqcar(arg, 'setq) then << tconc(arglist, cadr arg); tconc(arglist, form1(caddr arg, vars, mode)) >> else rederr {arg, "is not a proper initialization form for", constructor}; return constructor . car arglist; end; endmodule; module inspector; % Rlisp88 Code inspector. % Author: Jed Marti. % Description: Formats and displays the active annotation associated % with various RLISP data structures. % Notes: Things left to work on: % DEFINE constants. % SWITCH % CLASS, instances, scripts, etc. % The line numbers are pretty much the input expression numbers % (where comments are counted). Fixing this would require a % modification to the RLISP lexical scanner. % Dependencies: % Revision History: (Created Fri Jan 3 08:40:29 1992) % Wed Feb 26 09:39:28 1992 Add file/line numbers to functions. % Upgrade comments. % Sun Mar 1 11:09:30 1992 Try GLOBAL and FLUID declarations. Also % clear COMMENT!* after each use. % Fri Mar 13 17:28:41 1992 Add the comment reformatting routine % fmtcmt. % Fri Oct 8 12:06:00 1993 Fix use if ifl!*, remove printf's. Make % work with old RLISP syntax first. No active comments in this % code. expr procedure describe x; % DESCRIBE(X) -- Inspect any data structure X. This main routine % farms out the work accordingly. if pairp x then << prin2t "A dotted-pair or list"; nil >> else if vectorp x then if i!&recordinstp x then i!&recordinst x else <<prin2 "A vector with "; prin1 add1 upbv x; prin2t " elements"; nil>> else if codep x then <<prin2t "A code-pointer"; nil>> else if numberp x then if fixp x then <<prin2t "A fixed number"; nil>> else if floatp x then <<prin2t "A floating-point number"; nil>> else <<prin2t "An unknown type of number"; nil>> else if stringp x then <<prin2t "A string"; nil>> else if idp x then if i!&recordp x then i!&record x else if i!&functionp x then i!&function x else if i!&constantp x then i!&constant x else if i!&modulep x then i!&module x else if get(x, 'newnam) then i!&idnewnam x else i!&id x else <<prin2t "Can't inspect data structures of this type";nil>>; expr procedure i!&idnewnam x; % I!&IDNEWNAM(X) - This is the result of a define. <<prin1 x; prin2 " is a constant defined as "; print get(x,'newnam); if x := get(x,'active!-annotation) then if pairp x then i!&dump car x else i!&dump x>>; expr procedure i!&recordp x; % I!&RECORDP(X) -- X is an id. Returns T if this looks like an RLISP % record. get(x,'formfn) eq 'form!_record!_constructor; expr procedure i!&record x; % I!&RECORD(X) -- X is an id and the name of a record constructor. Try % and display as much about the record as possible. Note that record % instances are handled by the vector case temporarily. << prin1 x; prin2t " is a record constructor with the following fields"; prin2t "** not implemented. **"; nil >>; expr procedure i!&recordinstp x; % I!&RECORDINSTP(X) -- Returns T if X (a vector) looks like a record % instance. begin scalar tmp; if not idp getv(x,0) then return nil; if not (tmp := getd getv(x,0)) then return nil; if not eqcar(getd getv(x,0),'macro) then return nil; if atom (tmp := errorset({getv(x,0)},nil,nil)) then return nil; if upbv x neq upbv car tmp then return nil; return t end; expr procedure i!&recordinst x; % x is identified as a record. << prin2 "A "; prin1 getv(x,0); prin2t " record with "; for i:=1:upbv x do << prin2 " "; prin1 i; prin2 ": "; print getv(x,i)>>; nil >>; expr procedure i!&functionp x; % I!&FUNCTIONP(X) -- X is an id. Returns T if it is also the name of a % function or SMACRO. get(x, 'smacro) or getd x; expr procedure i!&function x; % I!&FUNCTION(X) - X is a function or SMACRO name. Farm out the % description based on its type. if get(x, 'smacro) then i!&function!-smacro x else (if eqcar(w, 'macro) then i!&function!-macro(x, cdr w) else if eqcar(w, 'expr) then i!&function!-expr(x, cdr w) else if eqcar(w, 'fexpr) then i!&function!-fexpr(x, cdr w) else i!&function!-unknown(x, w)) where w := getd x; expr procedure i!&function!-smacro x; % I!&FUNCTION!-SMACRO(X) -- X is the name of an SMACRO. Display what we % know about it. begin scalar tmp, d; d := get(x, 'smacro); prin1 x; prin2 " is an SMACRO with "; if not (tmp := get(x, 'number!-of!-args)) then if eqcar(d, 'lambda) and cdr d then tmp := length cadr d else tmp := nil; if onep tmp then prin2t "one argument" else if not tmp then prin2t "an unknown number of arguments" else << prin1 tmp; prin2t " arguments" >>; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp>> end; expr procedure i!&function!-expr(x, d); % I!&FUNCTION!-EXPR(X, D) -- X is the name of an EXPR type function and % D is it's definition. Display what we know about it. begin scalar tmp; prin1 x; prin2 " is an EXPR with "; if not (tmp := get(x, 'number!-of!-args)) then if eqcar(d, 'lambda) and cdr d then tmp := length cadr d else tmp := nil; if onep tmp then prin2t "one argument" else if not tmp then prin2t "an unknown number of arguments" else << prin1 tmp; prin2t " arguments" >>; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >> end; expr procedure i!&function!-fexpr(x, d); % I!&FUNCTION!-FEXPR(X, D) -- X is the name of an FEXPR type function % and D is its definition. Display what we know about it. begin scalar tmp; prin1 x; prin2t " is an FEXPR"; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >> end; expr procedure i!&function!-macro(x, d); % I!&FUNCTION!-MACRO(X, D) -- X is the name of a MACRO type function and % D its definition. Display what we know. begin scalar tmp; prin1 x; prin2t " is a MACRO"; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >> end; expr procedure i!&whereis x; % I!&WHEREIS(X) -- We might have a (comment line-number file). If so, % display this information. if length x = 3 then << prin2 "Function ends on line "; prin1 cadr x; prin2 " in file "; prin2t caddr x >>; expr procedure i!&constantp x; % I!&CONSTANTP(X) - Returns T if X is a constant. constantp x; expr procedure i!&id x; % I!&ID(X) -- X is an id see if we can find out anything about it. if globalp x then i!&id1(x, 'global) else if fluidp x then i!&id1(x, 'fluid) else << prin2 "Don't know anything about "; print x; nil >>; expr procedure i!&id1(x, ty); % I!&ID1(X, TY) -- X is TY (global or fluid). Print out what we know % about this id. begin scalar a; prin2 "Identifier '"; prin1 x; prin2 "' is "; prin2 ty; if a := get(x, 'active!-annotation) then if length a = 3 then << prin2 " defined line "; prin1 cadr a; prin2 " in file "; prin2t caddr a; i!&dump car a >> else i!&dump a else terpri() end; expr procedure i!&constant x; % I!&CONSTANT(X) - X is some sort of constant. Not much we can say about % it. <<prin1 x; prin2t " is a constant">>; expr procedure i!&modulep x; % I!&MODULEP(X) - Returns T if x looks like a module. flagp(x, 'module); expr procedure i!&module x; % I!&MODULE(X) - Display the facts about a module. (if filep r88 then i!&module1(x, i!&moduleb x, r88) else if filep rd then i!&module1(x, i!&moduleb x, rd) else i!&module2 x) where r88 := string!-downcase compress nconc('!" . explode2 x, '(!. !r !8 !8 !")), rd := string!-downcase compress nconc('!" . explode2 x, '(!. !r !e !d !")); expr procedure i!&module1(mname, bfile, sfile); % I!&MODULE(MNAME, BFILE, SFILE) - Display data about module MNAME % with object file BFILE, source file SFILE. PSL/UNIX specific. begin scalar sfs, bfs; if sfile then sfs := filestatus sfile; if bfile then bfs := filestatus bfile; if sfile then if bfile then << prin2 "Module "; prin1 mname; prin2 " source file "; prin2 sfile; prin2 " fasl file "; prin2 bfile; prin2 " and is "; print i!&dcomp(sfs, bfs) >> else << prin2 "Module "; prin1 mname; prin2 " has source file "; prin2 sfile; prin2 " written "; prin2t i!&sdt sfs >> else if bfile then << prin2 "Module "; prin1 mname; prin2 " has fasl file "; prin2 bfile; prin2 " written "; prin2t i!&sdt bfs >> else << prin2 "Module "; prin1 mname; prin2t ", can't find any files." >>; if sfs := get(mname, 'active!-annotation) then if pairp sfs then i!&dump car sfs else i!&dump sfs; end; expr procedure i!&module2 mname; % I!&MODULE2(MNAME) - called when we don't know much about a module. << prin2 "Can't find source or fasl file for module "; print mname; if sfs then if pairp sfs then i!&dump car sfs else i!&dump sfs >> where sfs := get(mname, 'active!-annotation); expr procedure i!&dcomp(s1, s2); % I!&DCOMP(S1, S2) -- two PSL file statuses. Compare the WRITETIMES % and return " OUT OF DATE." or " UP TO DATE.". if i!&dt s1 > i!&dt s2 then " out of date." else " up to date."; expr procedure i!&dt x; (if w then cddr w else 0) where w := atsoc('writetime, x); expr procedure i!&sdt x; (if w then cadr w else "no date") where w := atsoc('writetime, x); expr procedure i!&moduleb x; % I!&MODULEB(X) - Find which directory LOADDIRECTORIES!* the .b file % is and return the file name. begin scalar fs, fn; fs := loaddirectories!* while pairp fs do << fn := string!-downcase nconc('!" . explode2 car fs, nconc(explode2 x, '(!. !b !"))); if filep fn then fs := fn else fs := cdr fs >>; return fs end; %----------------------------------------------------------------------- % Basic active comment formatting. Remove the leading blank from the % first line, all blanks at start of each subsequent line, but only % of the shortest line. expr procedure i!&dump x; % I!&DUMP(X) - X is a string or something. Display its characters but % dump blanks at the beginning of each line as appropriate. begin scalar lnes, minsp, v; lnes := reversip i!&makelines(explode2 x, {nil}); minsp := 5000; for each x in cdr lnes do if (v:= i!&spcount x) < minsp then minsp := v; i!&prn i!&delspace(5000, car lnes); for each l in cdr lnes do i!&prn i!&delspace(minsp, l) end; expr procedure i!&makelines(x, l); % I!&MAKELINES(X, L) -- Remove EOL's form x and convert to a list of % sentences. L is used to build this list, call this with L = NIL. if null x then reversip car l . cdr l else if eqcar(x, !$eol!$) then i!&makelines(cdr x, nil . (reversip car l . cdr l)) else << car l := car x . car l; i!&makelines(cdr x, l) >>; expr procedure i!&spcount l; % I!&SPCOUNT(l) -- Count spaces in front of line l and return. if null l then 0 else if eqcar(l, '! ) then add1 i!&spcount cdr l else 0; expr procedure i!&delspace(n, l); % I!&DELSPACE(N, L) -- Delete n spaces from the front of line L and % return a new list. Quit if the list is short or runs into some % non-blank character. if null l then nil else if zerop n then l else if eqcar(l, '! ) then i!&delspace(n - 1, cdr l) else l; expr procedure i!&prn x; % I!&PRN(x) -- Display the characters of list x and then terminate the % line. << for each c in x do prin2 c; terpri() >>; %----------------------------------------------------------------------- % Hacks to make active comments work. fluid '(!*saveactives); switch saveactives; expr procedure i!&makeComment; % I!&MAKECOMMENT() - returns (comment line file) for packing active % annotation data away. mkquote {cadr Comment!*, curline!*, if ifl!* then car ifl!* else "unknown"}; expr procedure nformproc(a, b, c); % NFORMPROC(A, B, C) -- Temporary wrapper for FORMPROC to save the % function active annotation if the SAVEACTIVES switch is on. Also % put the file name and current line out there. begin scalar v,w; v := if !*saveactives and Comment!* then <<w := i!&makecomment(); put(cadr a,'active!-annotation,eval w); {'progn, {'cond,{'!*saveactives, {'put,mkquote cadr a,mkquote 'active!-annotation,w}}}, formproc(a, b, c)}>> else formproc(a, b, c); Comment!* := nil; return v end; put('procedure,'formfn,'nformproc); expr procedure formmodule(u, vars, mode); % FORMMODULE(U,VARS,MODE) - Save any active annotation on the property % of the module. Clear comment after use. begin scalar x; x := if !*saveactives and Comment!* then {'progn, {'cond, {'!*saveactives, {'put, mkquote cadr u, mkquote 'active!-annotation, i!&makecomment()}}}, {'flag, mkquote {cadr u}, mkquote 'MODULE}, {'module, mkquote{cdr u}}} else {'module, mkquote cdr u}; Comment!* := nil; return x end; % put('module, 'formfn, 'formmodule); expr procedure formglobalfluid(u, vars, mode); % FORMGLOBALFLUID(U, VARS, MODE) -- Attach active annotation to the % variables declared. if !*saveactives and Comment!* then {{'lambda, {'!$v!$}, {'progn, {'cond, {'!*saveactives, {'mapcar, '!$v!$, {'function, {'lambda, {'!$u!$}, {'put, '!$u!$, mkquote 'active!-annotation, i!&makeComment()}}}}}}, {car u, '!$v!$}}}, formc(cadr u, vars, mode)} else {car u, formc(cadr u, vars, mode)}; % put('global, 'formfn, 'formglobalfluid); % put('fluid, 'formfn, 'formglobalfluid); expr procedure fmtcmt(ano, ind, rm); begin scalar la, ind3, tcs, c, coll, colle, curbl, cbl; la := explode2 ano; if (ind3 := ind + 3) > (rm - 10) then error(0, "margins too small"); tcs := rm - ind3; % Remove extra blanks from front. % la := deblank la; % STATE 1: Now scan the lines dumping tokens to the output. spaces ind; prin2 "/* "; loop: if null la then return prin2 " */"; if c := fmtfulllineof(car la, la) then << la := fmtremoveline la; for i:=1:tcs do prin2 c; terpri(); spaces ind3; go to loop >> else if fmtblankline la then << if posn() > ind3 then terpri(); terpri(); spaces ind3; la := fmtremoveline la; go to loop >> else if eqcar(la, !$eol!$) then << terpri(); spaces ind3;go to loop >> else if eqcar(la, '! ) then go to state4; % STATE 2: Collect characters to EOL, blank, or NIL. state2: coll := colle := {car la}; la := cdr la; state2a: if null la then << fmtdumptok(coll, ind3, rm); go to loop >> else if eqcar(la, !$eol!$) then << fmtdumptok(coll, ind3, rm); la := cdr la; go to loop >> else if eqcar(la, '! ) then << fmtdumptok(coll, ind3, rm); go to state3 >>; cdr colle := {car la}; colle := cdr colle; la := cdr la; go to state2a; % STATE 3: Skip blanks to NIL, EOL, or next token. state3: if null la then go to loop else if eqcar(la, !$eol!$) then << la := cdr la; go to loop >> else if eqcar(la, '! ) then << la := cdr la; go to state3 >> else go to state2; % STATE 4: We've got a line that starts with a blank. Dump it to the % output line. state4: curbl := 0; cbl := t; state4a: prin2 car la; if cbl and eqcar(la, '! ) then curbl := add1 curbl else cbl := nil; la := cdr la; if null la then go to loop; if eqcar(la, !$eol!$) then << terpri(); spaces ind3;la := cdr la; go to loop >>; if posn() >= rm then << terpri(); spaces(1 + ind3 + curbl) >>; go to state4a end; expr procedure fmtblankline l; % FMTBLANKLINE(L) -- returns T if the rest of the current line is % all blanks. if null l or eqcar(l, !$eol!$) then t else if eqcar(l, '! ) then fmtblankline cdr l; expr procedure fmtfulllineof(c, la); % FMTFULLLINEOF(C, LA) -- Returns C if LA up to the end or !$EOL!$ is % all one character. if null la then c else if eqcar(la, c) then fmtfulllineof(c, cdr la) else if eqcar(la, !$eol!$) then c else nil; expr procedure fmtremoveline la; % FMTREMOVELINE(LA) -- returns the remainder of LA up to the end or the % first !$EOL!$. if la and not eqcar(la, !$eol!$) then fmtremoveline cdr la else cdr la; expr procedure fmtdumptok(l, ind, rm); if (length l + posn()) > rm then << terpri(); spaces ind; for each x in l do prin2 x; prin2 " " >> else << for each x in l do prin2 x; if posn() <= rm then prin2 " " >>; endmodule; end;