rlisp.red 94 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199
  1. % module module; % Support for module use.
  2. % Author: Anthony C. Hearn.
  3. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  4. fluid '(!*mode);
  5. global '(exportslist!* importslist!* module!-name!* old!-mode!*);
  6. !*mode := 'symbolic; % initial value.
  7. symbolic procedure exports u;
  8. begin exportslist!* := union(u,exportslist!*); end;
  9. symbolic procedure imports u;
  10. begin importslist!* := union(u,importslist!*); end;
  11. symbolic procedure module u;
  12. %Sets up a module definition;
  13. begin
  14. if null module!-name!* then old!-mode!* := !*mode;
  15. module!-name!* := car u . module!-name!*;
  16. !*mode := 'symbolic
  17. end;
  18. symbolic procedure endmodule;
  19. begin
  20. if null module!-name!*
  21. then rederr "ENDMODULE called outside module";
  22. exportslist!* := nil;
  23. importslist!* := nil;
  24. module!-name!* := cdr module!-name!*;
  25. if module!-name!* then return nil;
  26. !*mode := old!-mode!*;
  27. old!-mode!* := nil
  28. end;
  29. deflist('((exports rlis) (imports rlis) (module rlis)),'stat);
  30. put('endmodule,'stat,'rlis); % Done this way for bootstrapping purposes.
  31. flag('(endmodule),'go);
  32. % endmodule;
  33. module newtok; % Functions for introducing infix tokens to the system.
  34. % Author: Anthony C. Hearn.
  35. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  36. fluid '(!*redeflg!*);
  37. global '(!*msg preclis!*);
  38. %Several operators in REDUCE are used in an infix form (e.g.,
  39. %+,- ). The internal alphanumeric names associated with these
  40. %operators are introduced by the function NEWTOK defined below.
  41. %This association, and the precedence of each infix operator, is
  42. %initialized in this section. We also associate printing characters
  43. %with each internal alphanumeric name as well;
  44. preclis!*:= '(or and not member memq equal neq eq geq greaterp leq
  45. lessp freeof plus difference times quotient expt cons);
  46. deflist ('(
  47. (not not)
  48. (plus plus)
  49. (difference minus)
  50. (minus minus)
  51. (times times)
  52. (quotient recip)
  53. (recip recip)
  54. ), 'unary);
  55. flag ('(and or !*comma!* plus times),'nary);
  56. flag ('(cons setq plus times),'right);
  57. deflist ('((minus plus) (recip times)),'alt);
  58. symbolic procedure mkprec;
  59. begin scalar x,y,z;
  60. x := 'where . ('!*comma!* . ('setq . preclis!*));
  61. y := 1;
  62. a: if null x then return nil;
  63. put(car x,'infix,y);
  64. put(car x,'op,list list(y,y)); %for RPRINT;
  65. if z := get(car x,'unary) then put(z,'infix,y);
  66. if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y));
  67. x := cdr x;
  68. y := add1 y;
  69. go to a
  70. end;
  71. mkprec();
  72. symbolic procedure newtok u;
  73. begin scalar !*redeflg!*,x,y;
  74. if atom u or atom car u or null idp caar u
  75. then typerr(u,"NEWTOK argument");
  76. % set up SWITCH* property.
  77. put(caar u,'switch!*,
  78. cdr newtok1(car u,cadr u,get(caar u,'switch!*)));
  79. % set up PRTCH property.
  80. y := intern compress consescc car u;
  81. if !*redeflg!* then lprim list(y,"redefined");
  82. put(cadr u,'prtch,y);
  83. if x := get(cadr u,'unary) then put(x,'prtch,y)
  84. end;
  85. symbolic procedure newtok1(charlist,name,propy);
  86. if null propy then lstchr(charlist,name)
  87. else if null cdr charlist
  88. then begin
  89. if cdr propy and !*msg then !*redeflg!* := t;
  90. return list(car charlist,car propy,name)
  91. end
  92. else car charlist . newtok2(cdr charlist,name,car propy)
  93. . cdr propy;
  94. symbolic procedure newtok2(charlist,name,assoclist);
  95. if null assoclist then list lstchr(charlist,name)
  96. else if car charlist eq caar assoclist
  97. then newtok1(charlist,name,cdar assoclist) . cdr assoclist
  98. else car assoclist . newtok2(charlist,name,cdr assoclist);
  99. symbolic procedure consescc u;
  100. if null u then nil else '!! . car u . consescc cdr u;
  101. symbolic procedure lstchr(u,v);
  102. if null cdr u then list(car u,nil,v)
  103. else list(car u,list lstchr(cdr u,v));
  104. newtok '((!$) !*semicol!*);
  105. newtok '((!;) !*semicol!*);
  106. newtok '((!+) plus);
  107. newtok '((!-) difference);
  108. newtok '((!*) times);
  109. newtok '((!^) expt);
  110. newtok '((!* !*) expt);
  111. newtok '((!/) quotient);
  112. newtok '((!=) equal);
  113. newtok '((!,) !*comma!*);
  114. newtok '((!() !*lpar!*);
  115. newtok '((!)) !*rpar!*);
  116. newtok '((!:) !*colon!*);
  117. newtok '((!: !=) setq);
  118. newtok '((!.) cons);
  119. newtok '((!<) lessp);
  120. newtok '((!< !=) leq);
  121. newtok '((!< !<) !*lsqb!*);
  122. newtok '((!>) greaterp);
  123. newtok '((!> !=) geq);
  124. newtok '((!> !>) !*rsqb!*);
  125. put('expt,'prtch,'!*!*); % To ensure that FORTRAN output is correct.
  126. flag('(difference minus plus setq),'spaced);
  127. flag('(newtok),'eval);
  128. endmodule;
  129. module support; % Basic functions needed to support RLISP and REDUCE.
  130. % Author: Anthony C. Hearn.
  131. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  132. symbolic procedure aconc(u,v);
  133. %adds element v to the tail of u. u is destroyed in process;
  134. nconc(u,list v);
  135. symbolic procedure arrayp u; get(u,'rtype) eq 'array;
  136. symbolic procedure atsoc(u,v);
  137. if null v then nil
  138. else if u eq caar v then car v
  139. else atsoc(u,cdr v);
  140. symbolic procedure eqcar(u,v); null atom u and car u eq v;
  141. symbolic procedure flagpcar(u,v);
  142. null atom u and idp car u and flagp(car u,v);
  143. symbolic procedure idlistp u;
  144. % True if u is a list of id's.
  145. null u or null atom u and idp car u and idlistp cdr u;
  146. symbolic procedure mkprog(u,v); 'prog . (u . v);
  147. symbolic procedure mkquote u; list('quote,u);
  148. symbolic procedure mksetq(u,v); list('setq,u,v);
  149. symbolic procedure pairvars(u,vars,mode);
  150. % Sets up pairings of parameters and modes.
  151. begin scalar x;
  152. a: if null u then return append(reversip!* x,vars)
  153. else if null idp car u then symerr("Invalid parameter",nil);
  154. x := (car u . mode) . x;
  155. u := cdr u;
  156. go to a
  157. end;
  158. symbolic procedure prin2t u; progn(prin2 u, terpri(), u);
  159. symbolic procedure reversip u;
  160. begin scalar x,y;
  161. a: if null u then return y;
  162. x := cdr u; y := rplacd(u,y); u := x;
  163. go to a
  164. end;
  165. symbolic procedure smemq(u,v);
  166. %true if id U is a member of V at any level (excluding
  167. %quoted expressions);
  168. if atom v then u eq v
  169. else if car v eq 'quote then nil
  170. else smemq(u,car v) or smemq(u,cdr v);
  171. symbolic procedure union(x,y);
  172. if null x then y
  173. else union(cdr x,if car x member y then y else car x . y);
  174. symbolic procedure xn(u,v);
  175. if null u then nil
  176. else if car u member v then car u . xn(cdr u,delete(car u,v))
  177. else xn(cdr u,v);
  178. symbolic procedure u>=v; null(u<v);
  179. symbolic procedure u<=v; null(u>v);
  180. symbolic procedure u neq v; null(u=v);
  181. symbolic procedure setdiff(u,v);
  182. if null v then u else setdiff(delete(car v,u),cdr v);
  183. % symbolic smacro procedure u>=v; null(u<v);
  184. % symbolic smacro procedure u<=v; null(u>v);
  185. % symbolic smacro procedure u neq v; null(u=v);
  186. % List changing alternates (may also be defined as copying functions)
  187. symbolic procedure aconc!*(u,v); nconc(u,list v); % append(u,list v);
  188. symbolic procedure nconc!*(u,v); nconc(u,v); % append(u,v);
  189. symbolic procedure reversip!* u; reversip u; % reverse u;
  190. symbolic procedure rplaca!*(u,v); rplaca(u,v); % v . cdr u;
  191. symbolic procedure rplacd!*(u,v); rplacd(u,v); % car u . v;
  192. % The following functions should be provided in the compiler for
  193. % efficient coding.
  194. symbolic procedure apply1(u,v); apply(u,list v);
  195. symbolic procedure apply2(u,v,w); apply(u,list(v,w));
  196. symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x));
  197. % The following function is needed by several modules. It is more
  198. % REDUCE-specific than other functions in this module, but since it
  199. % needs to be defined early on, it might as well go here.
  200. symbolic procedure gettype u;
  201. % Returns a REDUCE-related type for the expression U.
  202. % It needs to be more table driven than the current definition.
  203. if numberp u then 'number
  204. else if null atom u or null u or null idp u then 'form
  205. else if get(u,'simpfn) then 'operator
  206. else if get(u,'avalue) then 'variable
  207. else if getd u then 'procedure
  208. else if globalp u then 'global
  209. else if fluidp u then 'fluid
  210. else if flagp(u,'parm) then 'parameter
  211. else get(u,'rtype);
  212. endmodule;
  213. module slfns; % Complete list of Standard LISP functions.
  214. % Author: Anthony C. Hearn.
  215. global '(!*argnochk slfns!*);
  216. slfns!* := '(
  217. (abs 1)
  218. (add1 1)
  219. (append 2)
  220. (apply 2)
  221. (assoc 2)
  222. (atom 1)
  223. (car 1)
  224. (cdr 1)
  225. (caar 1)
  226. (cadr 1)
  227. (cdar 1)
  228. (cddr 1)
  229. (caaar 1)
  230. (caadr 1)
  231. (cadar 1)
  232. (caddr 1)
  233. (cdaar 1)
  234. (cdadr 1)
  235. (cddar 1)
  236. (cdddr 1)
  237. (caaaar 1)
  238. (caaadr 1)
  239. (caadar 1)
  240. (caaddr 1)
  241. (cadaar 1)
  242. (cadadr 1)
  243. (caddar 1)
  244. (cadddr 1)
  245. (cdaaar 1)
  246. (cdaadr 1)
  247. (cdadar 1)
  248. (cdaddr 1)
  249. (cddaar 1)
  250. (cddadr 1)
  251. (cdddar 1)
  252. (cddddr 1)
  253. (close 1)
  254. (codep 1)
  255. (compress 1)
  256. (cons 2)
  257. (constantp 1)
  258. (de 3)
  259. (deflist 2)
  260. (delete 2)
  261. % (DF 3) conflicts with algebraic operator DF
  262. (difference 2)
  263. (digit 1)
  264. (divide 2)
  265. (dm 3)
  266. (dn 3)
  267. (ds 3)
  268. (eject 0)
  269. (eq 2)
  270. (eqn 2)
  271. (equal 2)
  272. (error 2)
  273. (errorset 3)
  274. (eval 1)
  275. (evlis 1)
  276. (expand 2)
  277. (explode 1)
  278. (expt 2)
  279. (fix 1)
  280. (fixp 1)
  281. (flag 2)
  282. (flagp 2)
  283. (float 1)
  284. (floatp 1)
  285. (fluid 1)
  286. (fluidp 1)
  287. (function 1)
  288. (gensym 0)
  289. (get 2)
  290. (getd 1)
  291. (getv 2)
  292. (global 1)
  293. (globalp 1)
  294. (go 1)
  295. (greaterp 2)
  296. (idp 1)
  297. (intern 1)
  298. (length 1)
  299. (lessp 2)
  300. (linelength 1)
  301. (liter 1)
  302. (lposn 0)
  303. (map 2)
  304. (mapc 2)
  305. (mapcan 2)
  306. (mapcar 2)
  307. (mapcon 2)
  308. (maplist 2)
  309. (max2 2)
  310. (member 2)
  311. (memq 2)
  312. (minus 1)
  313. (minusp 1)
  314. (min2 2)
  315. (mkvect 1)
  316. (nconc 2)
  317. (not 1)
  318. (null 1)
  319. (numberp 1)
  320. (onep 1)
  321. (open 2)
  322. (pagelength 1)
  323. (pair 2)
  324. (pairp 1)
  325. (plus2 2)
  326. (posn 0)
  327. (print 1)
  328. (prin1 1)
  329. (prin2 1)
  330. (prog2 2)
  331. (put 3)
  332. (putd 3)
  333. (putv 3)
  334. (quote 1)
  335. (quotient 2)
  336. (rds 1)
  337. (read 0)
  338. (readch 0)
  339. (remainder 2)
  340. (remd 1)
  341. (remflag 2)
  342. (remob 1)
  343. (remprop 2)
  344. (return 1)
  345. (reverse 1)
  346. (rplaca 2)
  347. (rplacd 2)
  348. (sassoc 3)
  349. (set 2)
  350. (setq 2)
  351. (stringp 1)
  352. (sublis 2)
  353. (subst 3)
  354. (sub1 1)
  355. (terpri 0)
  356. (times2 2)
  357. (unfluid 1)
  358. (upbv 1)
  359. (vectorp 1)
  360. (wrs 1)
  361. (zerop 1)
  362. );
  363. if !*argnochk then deflist(slfns!*,'number!-of!-args);
  364. endmodule;
  365. module superv; % REDUCE supervisory functions.
  366. % Author: Anthony C. Hearn.
  367. % Modified by: Jed B. Marti.
  368. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  369. fluid '(!*backtrace
  370. !*defn
  371. !*errcont
  372. !*int
  373. !*mode
  374. !*slin
  375. !*time
  376. dfprint!*
  377. lreadfn!*
  378. semic!*
  379. tslin!*);
  380. global '(!$eof!$
  381. !*byeflag!*
  382. !*demo
  383. !*echo
  384. !*extraecho
  385. !*lessspace
  386. !*micro!-version
  387. !*nosave!*
  388. !*output
  389. !*pret
  390. !*rlisp2
  391. !*strind
  392. !*struct
  393. cloc!*
  394. cmsg!*
  395. crbuf!*
  396. crbuflis!*
  397. crbuf1!*
  398. cursym!*
  399. eof!*
  400. erfg!*
  401. ifl!*
  402. ipl!*
  403. initl!*
  404. inputbuflis!*
  405. key!*
  406. ofl!*
  407. opl!*
  408. ogctime!*
  409. otime!*
  410. program!*
  411. programl!*
  412. promptexp!*
  413. resultbuflis!*
  414. st!*
  415. statcounter
  416. symchar!*
  417. tok!*
  418. ttype!*
  419. ws);
  420. !*output := t;
  421. eof!* := 0;
  422. initl!* := '(fname!* outl!*);
  423. statcounter := 0;
  424. % The true REDUCE supervisory function is BEGIN, again defined in the
  425. % system dependent part of this program. However, most of the work is
  426. % done by BEGIN1, which is called by BEGIN for every file encountered
  427. % on input;
  428. symbolic procedure errorp u;
  429. %returns true if U is an ERRORSET error format;
  430. atom u or cdr u;
  431. symbolic procedure flagp!*!*(u,v); idp u and flagp(u,v);
  432. symbolic procedure printprompt u;
  433. %Prints the prompt expression for input;
  434. progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*);
  435. symbolic procedure setcloc!*;
  436. % Used to set for file input a global variable CLOC!* to dotted pair
  437. % of file name and dotted pair of line and page being read.
  438. % Currently a place holder for system specific function, since not
  439. % supported in Standard LISP. CLOC!* is used in the INTER and RCREF
  440. % modules.
  441. cloc!* := if null ifl!* then nil else car ifl!* . nil;
  442. symbolic procedure command;
  443. begin scalar x;
  444. if !*demo and (x := ifl!*)
  445. then progn(terpri(),rds nil,readch(),rds cadr x);
  446. if null !*slin
  447. then if !*rlisp2
  448. then progn(s!&(),
  449. key!* := tok!*,
  450. m!-metarlisp(),
  451. (if st!* then x := car st!* else x := nil),
  452. st!* := nil)
  453. else progn(scan(), setcloc!*(), key!* := cursym!*,
  454. x := xread1 nil)
  455. else progn(key!* := (semic!* := '!;),
  456. setcloc!*(),
  457. x := (if lreadfn!* then apply(lreadfn!*,nil)
  458. else read()),
  459. if key!* eq '!;
  460. then key!* := if atom x then x else car x);
  461. if !*struct then x := structchk x;
  462. if !*pret then progn(terpri(),rprint x);
  463. if null !*slin then x := form x;
  464. return x
  465. end;
  466. symbolic procedure begin1;
  467. begin scalar mode,parserr,result,x;
  468. if !*rlisp2 then prolog 'm!-metarlisp;
  469. otime!* := time();
  470. % the next line is that way for bootstrapping purposes.
  471. if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0;
  472. a0: cursym!* := '!*semicol!*;
  473. a: if null terminalp() or !*nosave!* then go to b
  474. else if statcounter>0 then add2buflis();
  475. statcounter := statcounter + 1;
  476. crbuf1!* := nil; % For input string editor.
  477. !*strind := 0; % Used by some versions of input editor.
  478. promptexp!* :=
  479. compress('!! . append(explode statcounter,
  480. explode if null symchar!* or !*mode eq 'algebraic
  481. then '!:! else '!*! ));
  482. setpchar promptexp!*;
  483. b: parserr := nil;
  484. !*nosave!* := nil;
  485. if !*time then eval '(showtime); %Since a STAT;
  486. if !*output and null ofl!* and terminalp() and null !*defn
  487. and null !*lessspace
  488. then terpri();
  489. if tslin!*
  490. then progn(!*slin := car tslin!*,
  491. lreadfn!* := cdr tslin!*,
  492. tslin!* := nil);
  493. mapcar(initl!*,function sinitl);
  494. if !*int then erfg!* := nil; %to make editing work properly;
  495. if null !*rlisp2 and cursym!* eq 'end
  496. then progn(comm1 'end, return nil)
  497. else if terminalp() and (!*rlisp2 or null(key!* eq 'ed))
  498. then printprompt promptexp!*;
  499. program!* := errorset('(command),t,!*backtrace);
  500. if !*rlisp2
  501. then if tok!* eq '!*semic!* then semic!* := '!;
  502. else semic!* := '!$;
  503. condterpri();
  504. if errorp program!* then go to err1;
  505. program!* := car program!*;
  506. if eofcheck() then go to c else eof!* := 0;
  507. if !*rlisp2 then if program!* = '(end) then return nil else nil
  508. else if cursym!* eq 'end
  509. then if !*micro!-version and terminalp() then go to a0
  510. else progn(comm1 'end, return nil)
  511. else if eqcar(program!*,'retry) then program!* := programl!*;
  512. %The following section decides what the target mode should be.
  513. %That mode is also assumed to be the printing mode;
  514. if flagp!*!*(key!*,'modefn) then mode := key!*
  515. else if null atom program!* % and null !*micro!-version
  516. and null(car program!* eq 'quote)
  517. and (null(idp car program!*
  518. and (flagp(car program!*,'nochange)
  519. or flagp(car program!*,'intfn)
  520. or car program!* eq 'list))
  521. or car program!* memq '(setq setel setf)
  522. and eqcar(caddr program!*,'quote))
  523. then mode := 'symbolic
  524. else if key!* eq 'input
  525. and (x := rassoc!*(program!*,inputbuflis!*))
  526. then mode := cddr x
  527. else mode := !*mode;
  528. program!* := convertmode1(program!*,nil,'symbolic,mode);
  529. add2inputbuf(program!*,!*mode);
  530. % This used to be MODE, but then ED n wouldn't work.
  531. if null !*rlisp2 and null atom program!*
  532. and car program!* memq '(bye quit)
  533. then if getd 'bye then progn(eval program!*, go to b)
  534. else progn(!*byeflag!* := t, return nil)
  535. else if null !*rlisp2 and eqcar(program!*,'ed)
  536. then progn((if getd 'cedit and terminalp()
  537. then cedit cdr program!*
  538. else lprim "ED not supported"),
  539. go to b)
  540. else if !*defn
  541. then if erfg!* then go to a
  542. else if null flagp!*!*(key!*,'ignore)
  543. and null eqcar(program!*,'quote)
  544. then go to d;
  545. b1: if !*output and ifl!* and !*echo and null !*lessspace
  546. then terpri();
  547. result := errorset((if mode eq 'symbolic then program!*
  548. else list('assgneval,mkquote program!*)),
  549. t,!*backtrace);
  550. if errorp result or erfg!*
  551. then progn(programl!* := program!*,go to err2)
  552. else if !*defn then go to a;
  553. if null(mode eq 'symbolic)
  554. then progn(program!* := cdar result,
  555. result := list caar result);
  556. add2resultbuf(car result,mode);
  557. if null !*output then go to a
  558. else if (null !*rlisp2 and semic!* eq '!;)
  559. or (!*rlisp2 and tok!* eq '!*semic!*)
  560. then if mode eq 'symbolic
  561. then if null car result and null(!*mode eq 'symbolic)
  562. then nil
  563. else begin
  564. terpri();
  565. result := errorset(list('print,mkquote car result),
  566. t,!*backtrace)
  567. end
  568. else if car result
  569. then result := errorset(list('varpri,mkquote car result,
  570. mkquote program!*,
  571. mkquote 'only),
  572. t,!*backtrace);
  573. if errorp result then go to err3 else go to a;
  574. c: if crbuf1!* then
  575. progn(lprim "Closing object improperly removed. Redo edit.",
  576. crbuf1!* := nil, go to a)
  577. else if eof!*>4
  578. then progn(lprim "End-of-file read", return eval '(bye))
  579. else if terminalp() then progn(crbuf!* := nil, go to b)
  580. else return nil;
  581. d: if program!* then dfprint program!*;
  582. if null flagp!*!*(key!*,'eval) then go to a else go to b1;
  583. err1:
  584. if eofcheck() or eof!*>0 then go to c
  585. else if program!*="BEGIN invalid" then go to a;
  586. parserr := t;
  587. err2:
  588. resetparser(); %in case parser needs to be modified;
  589. err3:
  590. erfg!* := t;
  591. if null !*int and null !*errcont
  592. then progn(!*defn := t,
  593. !*echo := t,
  594. (if null cmsg!*
  595. then lprie "Continuing with parsing only ..."),
  596. cmsg!* := t)
  597. else if null !*errcont
  598. then progn(result := pause1 parserr,
  599. (if result then return null eval result),
  600. erfg!* := nil)
  601. else erfg!* := nil;
  602. go to a
  603. end;
  604. flag ('(deflist flag fluid global remflag remprop unfluid),'eval);
  605. symbolic procedure assgneval u;
  606. % Evaluate (possible) assignment statements and return results in a
  607. % form that allows required printing of such assignments.
  608. begin scalar x,y;
  609. a: if atom u then go to b
  610. else if car u eq 'setq then x := ('setq . cadr u) . x
  611. else if car u eq 'setel
  612. then x := ('setel . mkquote eval cadr u) . x
  613. else if car u eq 'setk
  614. then x := ('setk . mkquote if atom (y := eval cadr u) then y
  615. else car y . revlis cdr y) . x
  616. else go to b;
  617. u := caddr u;
  618. go to a;
  619. b: u := mkquote eval u;
  620. c: if null x then return(eval u . u);
  621. u := list(caar x,cdar x,u);
  622. x := cdr x;
  623. go to c
  624. end;
  625. symbolic procedure rassoc!*(u,v);
  626. % Finds term in which U is the first term in the right part of a term
  627. % in the association list V, or NIL if term is not found;
  628. if null v then nil
  629. else if u = cadar v then car v
  630. else rassoc!*(u,cdr v);
  631. symbolic procedure close!-input!-files;
  632. % Close all input files currently open;
  633. begin
  634. if ifl!* then progn(rds nil,ifl!* := nil);
  635. aa: if null ipl!* then return nil;
  636. close cdar ipl!*;
  637. ipl!* := cdr ipl!*;
  638. go to aa
  639. end;
  640. symbolic procedure close!-output!-files;
  641. % Close all output files currently open;
  642. begin
  643. if ofl!* then progn(wrs nil,ofl!* := nil);
  644. aa: if null opl!* then return nil;
  645. close cdar opl!*;
  646. opl!* := cdr opl!*;
  647. go to aa
  648. end;
  649. symbolic procedure add2buflis;
  650. begin
  651. if null crbuf!* then return nil;
  652. crbuf!* := reversip crbuf!*; %put in right order;
  653. a: if seprp car crbuf!* then progn(crbuf!* := cdr crbuf!*, go to a);
  654. crbuflis!* := (statcounter . crbuf!*) . crbuflis!*;
  655. crbuf!* := nil
  656. end;
  657. symbolic procedure add2inputbuf(u,mode);
  658. begin
  659. if null terminalp() or !*nosave!* then return nil;
  660. inputbuflis!* := (statcounter . u . mode) . inputbuflis!*
  661. end;
  662. symbolic procedure add2resultbuf(u,mode);
  663. begin
  664. if mode eq 'symbolic or null u or !*nosave!* then return nil;
  665. ws := u;
  666. if terminalp()
  667. then resultbuflis!* := (statcounter . u) . resultbuflis!*
  668. end;
  669. symbolic procedure condterpri;
  670. !*output and !*echo and !*extraecho and (null !*int or ifl!*)
  671. and null !*defn and terpri();
  672. symbolic procedure eofcheck;
  673. % true if an end-of-file has been read in current input sequence;
  674. program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1);
  675. symbolic procedure resetparser;
  676. %resets the parser after an error;
  677. if null !*slin then comm1 t;
  678. symbolic procedure terminalp;
  679. %true if input is coming from an interactive terminal;
  680. !*int and null ifl!*;
  681. symbolic procedure dfprint u;
  682. %Looks for special action on a form, otherwise prettyprints it;
  683. if dfprint!* then apply(dfprint!*,list u)
  684. else if cmsg!* then nil
  685. else if null eqcar(u,'progn) then prettyprint u
  686. else begin
  687. a: u := cdr u;
  688. if null u then return nil;
  689. dfprint car u;
  690. go to a
  691. end;
  692. symbolic procedure showtime;
  693. begin scalar x,y;
  694. x := otime!*;
  695. otime!* := time();
  696. x := otime!*-x;
  697. y := ogctime!*;
  698. ogctime!* := gctime();
  699. y := ogctime!* - y;
  700. x := x - y;
  701. terpri();
  702. prin2 "Time: "; prin2 x; prin2 " ms";
  703. if y = 0 then return terpri();
  704. prin2 " plus GC time: "; prin2 y; prin2 " ms"
  705. end;
  706. symbolic procedure sinitl u;
  707. set(u,get(u,'initl));
  708. endmodule;
  709. module tok; % Identifier and reserved character reading.
  710. % Author: Anthony C. Hearn.
  711. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  712. fluid '(semic!*);
  713. global '(!$eof!$
  714. !$eol!$
  715. !*quotenewnam
  716. !*raise
  717. crbuf!*
  718. crbuf1!*
  719. crchar!*
  720. curline!*
  721. cursym!*
  722. eof!*
  723. ifl!*
  724. nxtsym!*
  725. outl!*
  726. ttype!*);
  727. !*quotenewnam := t;
  728. crchar!* := '! ;
  729. curline!* := 1;
  730. % The function TOKEN defined below is used for reading identifiers
  731. % and reserved characters (such as parentheses and infix operators).
  732. % It is called by the function SCAN, which translates reserved
  733. % characters into their internal name, and sets up the output of the
  734. % input line. The following definitions of TOKEN and SCAN are quite
  735. % general, but also inefficient. The reading process can often be
  736. % speeded up considerably if these functions (especially token) are
  737. % written in terms of the explicit LISP used.
  738. symbolic procedure prin2x u;
  739. outl!* := u . outl!*;
  740. symbolic procedure mkstrng u;
  741. %converts the uninterned id U into a string;
  742. %if strings are not constants, this should be replaced by
  743. %list('string,u);
  744. u;
  745. symbolic procedure readch1;
  746. begin scalar x;
  747. if null terminalp()
  748. then progn(x := readch(),
  749. x eq !$eol!$ and (curline!* := curline!*+1),
  750. return x)
  751. else if crbuf1!*
  752. then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end
  753. else x := readch();
  754. crbuf!* := x . crbuf!*;
  755. return x
  756. end;
  757. symbolic procedure token1;
  758. begin scalar x,y,z;
  759. x := crchar!*;
  760. a: if seprp x then progn(x := readch1(), go to a)
  761. else if digit x then go to number
  762. else if liter x then go to letter
  763. else if x eq '!% then go to coment
  764. else if x eq '!! then go to escape
  765. else if x eq '!'
  766. then progn(crchar!* := readch1(),
  767. nxtsym!* := mkquote rread(),
  768. ttype!* := 4,
  769. return nxtsym!*)
  770. else if x eq '!" then go to string;
  771. ttype!* := 3;
  772. if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr());
  773. nxtsym!* := x;
  774. a1: if delcp x then crchar!*:= '! else crchar!*:= readch1();
  775. go to c;
  776. escape:
  777. begin scalar raise;
  778. raise := !*raise;
  779. !*raise := nil;
  780. y := x . y;
  781. x := readch1();
  782. !*raise := raise
  783. end;
  784. letter:
  785. ttype!* := 0;
  786. let1:
  787. y := x . y;
  788. if digit (x := readch1()) or liter x then go to let1
  789. else if x eq '!! then go to escape;
  790. nxtsym!* := intern compress reversip!* y;
  791. b: crchar!* := x;
  792. c: return nxtsym!*;
  793. number:
  794. ttype!* := 2;
  795. num1:
  796. y := x . y;
  797. z := x;
  798. if digit (x := readch1())
  799. or x eq '!.
  800. or x eq 'e
  801. or z eq 'e
  802. then go to num1;
  803. nxtsym!* := compress reversip!* y;
  804. go to b;
  805. string:
  806. begin scalar raise;
  807. raise := !*raise;
  808. !*raise := nil;
  809. strinx:
  810. y := x . y;
  811. if null((x := readch1()) eq '!") then go to strinx;
  812. y := x . y;
  813. nxtsym!* := mkstrng compress reversip!* y;
  814. !*raise := raise
  815. end;
  816. ttype!* := 1;
  817. go to a1;
  818. coment:
  819. if null(readch1() eq !$eol!$) then go to coment;
  820. x := readch1();
  821. go to a
  822. end;
  823. symbolic procedure token;
  824. %This provides a hook for a faster TOKEN;
  825. token1();
  826. symbolic procedure filenderr;
  827. begin
  828. eof!* := eof!*+1;
  829. if terminalp() then error1()
  830. else error(99,if ifl!*
  831. then list("End-of-file read in file",car ifl!*)
  832. else "End-of-file read")
  833. end;
  834. symbolic procedure ptoken;
  835. begin scalar x;
  836. x := token();
  837. if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*;
  838. %an explicit reference to OUTL!* used here;
  839. prin2x x;
  840. if null ((x eq '!() or (x eq '!))) then prin2x '! ;
  841. return x
  842. end;
  843. symbolic procedure rread1;
  844. % Modified to use QUOTENEWNAM's for ids.
  845. begin scalar x,y;
  846. x := ptoken();
  847. if null (ttype!*=3)
  848. then return if null idp x
  849. or null !*quotenewnam
  850. or null(y := get(x,'quotenewnam))
  851. then x
  852. else y
  853. else if x eq '!( then return rrdls()
  854. else if null (x eq '!+ or x eq '!-) then return x;
  855. y := ptoken();
  856. if null numberp y
  857. then progn(nxtsym!* := " ",
  858. symerr("Syntax error: improper number",nil))
  859. else if x eq '!- then y := apply('minus,list y);
  860. %we need this construct for bootstrapping purposes;
  861. return y
  862. end;
  863. symbolic procedure rrdls;
  864. begin scalar x,y,z;
  865. a: x := rread1();
  866. if null (ttype!*=3) then go to b
  867. else if x eq '!) then return z
  868. else if null (x eq '!.) then go to b;
  869. x := rread1();
  870. y := ptoken();
  871. if null (ttype!*=3) or null (y eq '!))
  872. then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil))
  873. else return nconc(z,x);
  874. b: z := nconc(z,list x);
  875. go to a
  876. end;
  877. symbolic procedure rread;
  878. progn(prin2x " '",rread1());
  879. symbolic procedure scan;
  880. begin scalar x,y;
  881. if null (cursym!* eq '!*semicol!*) then go to b;
  882. a: nxtsym!* := token();
  883. b: if null atom nxtsym!* then go to q1
  884. else if nxtsym!* eq 'else or cursym!* eq '!*semicol!*
  885. then outl!* := nil;
  886. prin2x nxtsym!*;
  887. c: if null idp nxtsym!* then go to l
  888. else if (x:=get(nxtsym!*,'newnam)) and
  889. (null (x=nxtsym!*)) then go to new
  890. else if nxtsym!* eq 'comment OR NXTSYM!* EQ '!% AND TTYPE!*=3
  891. THEN GO TO COMM
  892. ELSE IF NULL(TTYPE!* = 3) THEN GO TO L
  893. ELSE IF NXTSYM!* EQ !$eof!$ then return filenderr()
  894. else if nxtsym!* eq '!' then go to quote
  895. else if null (x:= get(nxtsym!*,'switch!*)) then go to l
  896. else if eqcar(cdr x,'!*semicol!*) then go to delim;
  897. sw1: nxtsym!* := token();
  898. if null(ttype!* = 3) then go to sw2
  899. else if nxtsym!* eq !$eof!$ then return filenderr()
  900. else if car x then go to sw3;
  901. sw2: cursym!*:=cadr x;
  902. if cursym!* eq '!*rpar!* then go to l2
  903. else return cursym!*;
  904. sw3: if null (y:= atsoc(nxtsym!*,car x)) then go to sw2;
  905. prin2x nxtsym!*;
  906. x := cdr y;
  907. go to sw1;
  908. comm: if delcp crchar!* then go to com1;
  909. crchar!* := readch();
  910. go to comm;
  911. com1: crchar!* := '! ;
  912. condterpri();
  913. go to a;
  914. delim:
  915. semic!*:=nxtsym!*;
  916. return (cursym!*:='!*semicol!*);
  917. new: nxtsym!* := x;
  918. if stringp x then go to l
  919. else if atom x then go to c
  920. else go to l;
  921. quote:
  922. nxtsym!* := mkquote rread1();
  923. go to l;
  924. q1: if null (car nxtsym!* eq 'string) then go to l;
  925. prin2x " ";
  926. prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*);
  927. l: cursym!*:=nxtsym!*;
  928. l1: nxtsym!* := token();
  929. if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr();
  930. l2: if numberp nxtsym!*
  931. or (atom nxtsym!* and null get(nxtsym!*,'switch!*))
  932. then prin2x " ";
  933. return cursym!*
  934. end;
  935. endmodule;
  936. module xread; % Routines for parsing REDUCE input.
  937. % Author: Anthony C. Hearn.
  938. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  939. fluid '(!*blockp);
  940. global '(cursym!* nxtsym!*);
  941. % The conversion of a REDUCE expression to LISP prefix form is carried
  942. % out by the function XREAD. This function initiates the scanning
  943. % process, and then calls the auxiliary function XREAD1 to perform the
  944. % actual parsing. Both XREAD and XREAD1 are used by many functions
  945. % whenever an expression must be read;
  946. flag ('(end !*colon!* !*semicol!*),'delim);
  947. symbolic procedure chknewnam u;
  948. % Check to see if U has a newnam, and return it else return U.
  949. begin scalar x;
  950. return if null(x := get(u,'newnam)) or x eq u then u
  951. else if idp x then chknewnam x
  952. else x
  953. end;
  954. symbolic procedure mkvar(u,v); u;
  955. symbolic procedure remcomma u;
  956. if eqcar(u,'!*comma!*) then cdr u else list u;
  957. symbolic procedure xread1 u;
  958. begin scalar v,w,x,y,z,z1,z2;
  959. % v: expression being built
  960. % w: prefix operator stack
  961. % x: infix operator stack
  962. % y: infix value or stat property
  963. % z: current symbol
  964. % z1: next symbol
  965. % z2: temporary storage;
  966. a: z := cursym!*;
  967. a1: if null idp z then nil
  968. else if z eq '!*lpar!* then go to lparen
  969. else if z eq '!*rpar!* then go to rparen
  970. else if y := get(z,'infix) then go to infx
  971. % The next line now commented out was intended to allow a STAT
  972. % to be used as a label. However, it prevents the definition of
  973. % a diphthong whose first character is a colon.
  974. % else if nxtsym!* eq '!: then nil
  975. else if flagp(z,'delim) then go to delimit
  976. else if y := get(z,'stat) then go to stat;
  977. a2: y := nil;
  978. a3: w := z . w;
  979. if numberp z
  980. and idp (z1 := chknewnam nxtsym!*)
  981. and null flagp(z1,'delim)
  982. and null(get(z1,'switch!*) and null(z1 eq '!())
  983. and null get(z1,'infix)
  984. then progn(cursym!* := 'times, go to a);
  985. % allow for implicit * after a number.
  986. next: z := scan();
  987. go to a1;
  988. lparen:
  989. y := nil;
  990. if scan() eq '!*rpar!* then go to lp1 % no args
  991. else if flagpcar(w,'struct) then z := xread1 car w
  992. else z := xread1 'paren;
  993. if flagp(u,'struct) then progn(z := remcomma z, go to a3)
  994. else if null eqcar(z,'!*comma!*) then go to a3
  995. else if null w
  996. then (if u eq 'lambda then go to a3
  997. else symerr("Improper delimiter",nil))
  998. else w := (car w . cdr z) . cdr w;
  999. go to next;
  1000. lp1: if w then w := list car w . cdr w; %function of no args;
  1001. go to next;
  1002. rparen:
  1003. if null u or u eq 'group or u eq 'proc
  1004. then symerr("Too many right parentheses",nil)
  1005. else go to end1;
  1006. infx: if z eq '!*comma!* or null atom (z1 := scan())
  1007. or numberp z1 then go to in1
  1008. else if z1 eq '!*rpar!*%infix operator used as variable;
  1009. or z1 eq '!*comma!*
  1010. or flagp(z1,'delim)
  1011. then go to in2
  1012. else if z1 eq '!*lpar!*%infix operator in prefix position;
  1013. and null atom(z1 := xread 'paren)
  1014. and car z1 eq '!*comma!*
  1015. and (z := z . cdr z1)
  1016. then go to a1;
  1017. in1: if w then go to unwind
  1018. else if null(z := get(z,'unary))
  1019. then symerr("Redundant operator",nil);
  1020. v := '!*!*un!*!* . v;
  1021. go to pr1;
  1022. in2: y := nil;
  1023. w := z . w;
  1024. in3: z := z1;
  1025. go to a1;
  1026. unwind:
  1027. z2 := mkvar(car w,z);
  1028. un1: w:= cdr w;
  1029. if null w then go to un2
  1030. else if numberp car w then symerr("Missing operator",nil);
  1031. z2 := list(car w,z2);
  1032. go to un1;
  1033. un2: v:= z2 . v;
  1034. preced:
  1035. if null x then if y=0 then go to end2 else nil
  1036. else if y<caar x
  1037. or (y=caar x
  1038. and ((z eq cdar x and null flagp(z,'nary)
  1039. and null flagp(z,'right))
  1040. or get(cdar x,'alt)))
  1041. then go to pr2;
  1042. pr1: x:= (y . z) . x;
  1043. if null(z eq '!*comma!*) then go to in3
  1044. else if cdr x or null u or u memq '(lambda paren)
  1045. or flagp(u,'struct)
  1046. then go to next
  1047. else go to end2;
  1048. pr2: %if cdar x eq 'setq then go to assign else;
  1049. if cadr v eq '!*!*un!*!*
  1050. then (if car v eq '!*!*un!*!* then go to pr1
  1051. else z2 := list(cdar x,car v))
  1052. else z2 := cdar x .
  1053. if eqcar(car v,cdar x) and flagp(cdar x,'nary)
  1054. then (cadr v . cdar v)
  1055. else list(cadr v,car v);
  1056. x:= cdr x;
  1057. v := z2 . cddr v;
  1058. go to preced;
  1059. stat: if null(flagp(z,'go)
  1060. or null(u eq 'proc) and (flagp(y,'endstat)
  1061. or (null delcp nxtsym!* and null (nxtsym!* eq '!,))))
  1062. then go to a2;
  1063. w := apply(y,nil) . w;
  1064. y := nil;
  1065. go to a;
  1066. delimit:
  1067. if z eq '!*colon!* and null(u eq 'for)
  1068. and (null !*blockp or null w or null atom car w or cdr w)
  1069. or flagp(z,'nodel)
  1070. and (null u
  1071. or u eq 'group and null z memq '(!*rsqb!* !*rcbkt!*))
  1072. then symerr("Improper delimiter",nil)
  1073. else if idp u and (u eq 'paren or flagp(u,'struct))
  1074. then symerr("Too few right parentheses",nil);
  1075. end1: if y then symerr("Improper delimiter",nil)
  1076. else if null v and null w and null x then return nil;
  1077. y := 0;
  1078. go to unwind;
  1079. end2: if null cdr v then return car v
  1080. else symerr("Improper delimiter",nil)
  1081. end;
  1082. %symbolic procedure getels u;
  1083. % getel(car u . !*evlis cdr u);
  1084. %symbolic procedure !*evlis u;
  1085. % mapcar(u,function eval);
  1086. flag ('(endstat retstat),'endstat);
  1087. flag ('(else until),'nodel);
  1088. flag ('(begin),'go);
  1089. symbolic procedure xread u;
  1090. progn(scan(),xread1 u);
  1091. flag('(xread),'opfn); %to make it an operator;
  1092. endmodule;
  1093. module lpri; % Functions for printing diagnostic and error messages.
  1094. % Author: Anthony C. Hearn.
  1095. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  1096. fluid '(!*defn !*int);
  1097. global '(!*echo !*fort !*msg !*nat !*rlisp2 cursym!* erfg!* ofl!*
  1098. outl!*);
  1099. symbolic procedure lpri u;
  1100. begin
  1101. a: if null u then return nil;
  1102. prin2 car u;
  1103. prin2 " ";
  1104. u := cdr u;
  1105. go to a
  1106. end;
  1107. symbolic procedure lpriw (u,v);
  1108. begin scalar x;
  1109. u := u . if v and atom v then list v else v;
  1110. if ofl!* and (!*fort or not !*nat or !*defn) then go to c;
  1111. terpri();
  1112. a: lpri u;
  1113. terpri();
  1114. if null x then go to b;
  1115. wrs cdr x;
  1116. return nil;
  1117. b: if null ofl!* then return nil;
  1118. c: x := ofl!*;
  1119. wrs nil;
  1120. go to a
  1121. end;
  1122. symbolic procedure lprim u;
  1123. !*msg and lpriw("***",u);
  1124. symbolic procedure lprie u;
  1125. begin scalar x;
  1126. if !*int then go to a;
  1127. x:= !*defn;
  1128. !*defn := nil;
  1129. a: erfg!* := t;
  1130. lpriw ("*****",u);
  1131. if null !*int then !*defn := x
  1132. end;
  1133. symbolic procedure printty u;
  1134. begin scalar ofl;
  1135. if null !*fort and !*nat then print u;
  1136. if null ofl!* then return nil;
  1137. ofl := ofl!*;
  1138. wrs nil;
  1139. print u;
  1140. wrs cdr ofl
  1141. end;
  1142. symbolic procedure rederr u;
  1143. begin lprie u; error1() end;
  1144. symbolic procedure symerr(u,v);
  1145. begin scalar x;
  1146. erfg!* := t;
  1147. if numberp cursym!* or not(x := get(cursym!*,'prtch))
  1148. then x := cursym!*;
  1149. terpri();
  1150. if !*echo then terpri();
  1151. outl!*:=car outl!* . '!$!$!$ . cdr outl!*;
  1152. comm1 t;
  1153. mapcar(reversip!* outl!*,function prin2);
  1154. terpri();
  1155. outl!* := nil;
  1156. if null v then rederr u
  1157. else rederr(x . ("invalid" .
  1158. (if u then list("in",u,"statement") else nil)))
  1159. end;
  1160. symbolic procedure typerr(u,v); rederr list(u,"invalid as",v);
  1161. endmodule;
  1162. module parser; % Functions for parsing RLISP expressions.
  1163. % Author: Anthony C. Hearn.
  1164. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  1165. fluid '(!*backtrace !*mode);
  1166. global '(cursym!* letl!* nxtsym!*);
  1167. %With the exception of assignment statements, which are handled by
  1168. %XREAD, statements in REDUCE are introduced by a key-word, which
  1169. %initiates a reading process peculiar to that statement. The key-word
  1170. %is recognized (in XREAD1) by the indicator STAT on its property list.
  1171. %The corresponding property is the name of the function (of no
  1172. %arguments) which carries out the reading sequence.
  1173. % ***** COMMENTS *****
  1174. symbolic procedure comm1 u;
  1175. begin scalar bool;
  1176. if u eq 'end then go to b;
  1177. a: if cursym!* eq '!*semicol!*
  1178. or u eq 'end
  1179. and cursym!* memq
  1180. '(end else then until !*rpar!* !*rsqb!*)
  1181. then return nil
  1182. else if u eq 'end and null bool
  1183. then progn(lprim list("END-COMMENT NO LONGER SUPPORTED"),
  1184. bool := t);
  1185. b: scan();
  1186. go to a
  1187. end;
  1188. % ***** CONDITIONAL STATEMENT *****
  1189. symbolic procedure ifstat;
  1190. begin scalar condx,condit;
  1191. a: condx := xread t;
  1192. if not cursym!* eq 'then then symerr('if,t);
  1193. condit := aconc!*(condit,list(condx,xread t));
  1194. if not cursym!* eq 'else then nil
  1195. else if scan() eq 'if then go to a
  1196. else condit := aconc!*(condit,list(t,xread1 t));
  1197. return ('cond . condit)
  1198. end;
  1199. put('if,'stat,'ifstat);
  1200. flag ('(then else),'delim);
  1201. % ***** LAMBDA STATEMENT *****
  1202. symbolic procedure lamstat;
  1203. begin scalar x,y;
  1204. x:= xread 'lambda;
  1205. % x := flagtype(if null x then nil else remcomma x,'scalar);
  1206. if x then x := remcomma x;
  1207. y := list('lambda,x,xread t);
  1208. % remtype x;
  1209. return y
  1210. end;
  1211. put ('lambda,'stat,'lamstat);
  1212. % ***** GROUP STATEMENT *****
  1213. symbolic procedure mkprogn;
  1214. %Expects a list of statements terminated by a >>;
  1215. begin scalar lst;
  1216. a: lst := aconc!*(lst,xread 'group);
  1217. if null(cursym!* eq '!*rsqb!*) then go to a;
  1218. scan();
  1219. return ('progn . lst)
  1220. end;
  1221. put('!*lsqb!*,'stat,'mkprogn);
  1222. flag('(!*rsqb!*),'delim);
  1223. flag('(!*rsqb!*),'nodel);
  1224. % ***** END STATEMENT *****
  1225. symbolic procedure endstat;
  1226. %This procedure can also be used for any key-words which take no
  1227. %arguments;
  1228. begin scalar x; x := cursym!*; comm1 'end; return list x end;
  1229. put('end,'stat,'endstat);
  1230. put('endmodule,'stat,'endstat);
  1231. put('bye,'stat,'endstat);
  1232. put('quit,'stat,'endstat);
  1233. flag('(bye quit),'eval);
  1234. put('showtime,'stat,'endstat);
  1235. endmodule;
  1236. module block; % Block statement and related operators.
  1237. % Author: Anthony C. Hearn.
  1238. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  1239. fluid '(!*blockp);
  1240. global '(!*vars!* cursym!* nxtsym!*);
  1241. % ***** GO statement *****
  1242. symbolic procedure gostat;
  1243. begin scalar var;
  1244. var := if eq(scan(),'to) then scan() else cursym!*;
  1245. scan();
  1246. return list('go,var)
  1247. end;
  1248. put('go,'stat,'gostat);
  1249. put('goto,'newnam,'go);
  1250. % ***** Declaration Statement *****
  1251. symbolic procedure decl u;
  1252. begin scalar varlis,w;
  1253. a: if cursym!* eq '!*semicol!* then go to c
  1254. else if not flagp!*!*(cursym!*,'type) then return varlis
  1255. else if cursym!* eq 'dcl then go to dclr;
  1256. w := cursym!*;
  1257. if scan() eq 'procedure then return procstat1 w;
  1258. varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w));
  1259. b: if not cursym!* eq '!*semicol!* then symerr(nil,t)
  1260. else if null u then return list('dcl,mkquote varlis);
  1261. %top level declaration;
  1262. c: scan();
  1263. go to a;
  1264. dclr: varlis := append(varlis,dclstat1());
  1265. go to b
  1266. end;
  1267. flag ('(dcl real integer scalar),'type);
  1268. symbolic procedure dclstat; list('dcl,mkquote dclstat1());
  1269. symbolic procedure dclstat1;
  1270. begin scalar x,y;
  1271. a: x := xread nil;
  1272. if not cursym!* eq '!*colon!* then symerr('dcl,t);
  1273. y := append(y,pairvars(remcomma x,nil,scan()));
  1274. if scan() eq '!*semicol!* then return y
  1275. else if not cursym!* eq '!*comma!* then symerr('dcl,t)
  1276. else go to a
  1277. end;
  1278. symbolic procedure dcl u;
  1279. %U is a list of (id, mode) pairs, which are declared as global vars;
  1280. begin scalar x;
  1281. !*vars!* := append(u,!*vars!*);
  1282. x := mapcar(u,function car);
  1283. global x;
  1284. flag(x,'share);
  1285. a: if null u then return nil;
  1286. set(caar u,get(cdar u,'initvalue));
  1287. u := cdr u;
  1288. go to a
  1289. end;
  1290. put('integer,'initvalue,0);
  1291. put('dcl,'stat,'dclstat);
  1292. symbolic procedure decstat;
  1293. %only called if a declaration occurs at the top level or not first
  1294. %in a block;
  1295. begin scalar x,y,z;
  1296. if !*blockp then symerr('block,t);
  1297. x := cursym!*;
  1298. y := nxtsym!*;
  1299. z := decl nil;
  1300. if y neq 'procedure then rederr list(x,"invalid outside block");
  1301. return z
  1302. end;
  1303. put('integer,'stat,'decstat);
  1304. put('real,'stat,'decstat);
  1305. put('scalar,'stat,'decstat);
  1306. % ***** Block Statement *****
  1307. symbolic procedure blockstat;
  1308. begin scalar hold,varlis,x,!*blockp;
  1309. !*blockp := t;
  1310. scan();
  1311. if cursym!* memq '(nil !*rpar!*) then rederr "BEGIN invalid";
  1312. varlis := decl t;
  1313. a: if cursym!* eq 'end and not nxtsym!* eq '!: then go to b;
  1314. x := xread1 nil;
  1315. if eqcar(x,'end) then go to c;
  1316. not cursym!* eq 'end and scan();
  1317. if x then hold := aconc!*(hold,x);
  1318. go to a;
  1319. b: comm1 'end;
  1320. c: return mkblock(varlis,hold)
  1321. end;
  1322. symbolic procedure mkblock(u,v); 'block . (u . v);
  1323. putd('block,'macro,
  1324. '(lambda (u) (cons 'prog
  1325. (cons (mapcar (cadr u) (function car)) (cddr u)))));
  1326. symbolic procedure formblock(u,vars,mode);
  1327. 'prog . append(initprogvars cadr u,
  1328. formprog1(cddr u,append(cadr u,vars),mode));
  1329. symbolic procedure initprogvars u;
  1330. begin scalar x,y,z;
  1331. a: if null u then return(reversip!* x . reversip!* y)
  1332. else if z := get(cdar u,'initvalue)
  1333. then y := mksetq(caar u,z) . y;
  1334. x := caar u . x;
  1335. u := cdr u;
  1336. go to a
  1337. end;
  1338. symbolic procedure formprog(u,vars,mode);
  1339. 'prog . cadr u . formprog1(cddr u,pairvars(cadr u,vars,mode),mode);
  1340. symbolic procedure formprog1(u,vars,mode);
  1341. if null u then nil
  1342. else if atom car u then car u . formprog1(cdr u,vars,mode)
  1343. else if idp caar u and flagp(caar u,'modefn)
  1344. then formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode)
  1345. else formc(car u,vars,mode) . formprog1(cdr u,vars,mode);
  1346. put('block,'formfn,'formblock);
  1347. put('prog,'formfn,'formprog);
  1348. put('begin,'stat,'blockstat);
  1349. % ***** Return Statement *****
  1350. symbolic procedure retstat;
  1351. if not !*blockp then symerr(nil,t)
  1352. else list('return,
  1353. if flagp!*!*(scan(),'delim) then nil else xread1 t);
  1354. put('return,'stat,'retstat);
  1355. endmodule;
  1356. module form; % Performs a mode analysis of parsed forms.
  1357. % Author: Anthony C. Hearn.
  1358. % Modifications by: Jed Marti.
  1359. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  1360. fluid '(!*!*a2sfn !*cref !*defn !*mode current!-modulus);
  1361. global '(!*argnochk !*composites !*force !*micro!-version !*vars!*);
  1362. !*!*a2sfn := 'aeval;
  1363. flag('(algebraic symbolic),'modefn);
  1364. symbolic procedure formcond(u,vars,mode);
  1365. 'cond . formcond1(cdr u,vars,mode);
  1366. symbolic procedure formcond1(u,vars,mode);
  1367. if null u then nil
  1368. else list(formbool(caar u,vars,mode),form1(cadar u,vars,mode))
  1369. % FORMC here would add REVAL
  1370. . formcond1(cdr u,vars,mode);
  1371. put('cond,'formfn,'formcond);
  1372. symbolic procedure formlamb(u,vars,mode);
  1373. list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode));
  1374. put('lambda,'formfn,'formlamb);
  1375. symbolic procedure formprogn(u,vars,mode);
  1376. 'progn . formclis(cdr u,vars,mode);
  1377. put('progn,'formfn,'formprogn);
  1378. symbolic procedure expdrmacro u;
  1379. %returns the macro form for U if expansion is permitted;
  1380. begin scalar x;
  1381. if null(x := getrmacro u) or flagp(u,'noexpand) then return nil
  1382. else if null !*cref and (null !*defn or car x eq 'smacro)
  1383. or flagp(u,'expand) or !*force
  1384. then return x
  1385. else return nil
  1386. end;
  1387. symbolic procedure getrmacro u;
  1388. %returns a Reduce macro definition for U, if one exists,
  1389. %in GETD format;
  1390. begin scalar x;
  1391. return if not idp u then nil
  1392. else if (x := getd u) and car x eq 'macro then x
  1393. else if (x := get(u,'smacro)) then 'smacro . x
  1394. % else if (x := get(u,'nmacro)) then 'nmacro . x;
  1395. else nil
  1396. end;
  1397. symbolic procedure applmacro(u,v,w); apply1(u,w . v);
  1398. %symbolic procedure applnmacro(u,v,w);
  1399. % apply(u,if flagp(w,'nospread) then list v else v);
  1400. % symbolic procedure applsmacro(u,v,w);
  1401. % %We could use an atom sublis here, eg SUBLA;
  1402. % sublis(pair(cadr u,v),caddr u);
  1403. put('macro,'macrofn,'applmacro);
  1404. %put('nmacro,'macrofn,'applnmacro);
  1405. put('smacro,'macrofn,'applsmacro);
  1406. flag('(ed go quote),'noform);
  1407. symbolic procedure set!-global!-mode u;
  1408. begin !*mode := u end;
  1409. symbolic procedure form1(u,vars,mode);
  1410. begin scalar x,y;
  1411. if atom u
  1412. then return if not idp u then u
  1413. else if u eq 'ed then list u
  1414. else if flagp(u,'modefn) then set!-global!-mode u
  1415. else if x:= get(mode,'idfn)
  1416. then apply2(x,u,vars)
  1417. else u
  1418. else if not atom car u
  1419. then if caar u eq 'lambda then return formlis(u,vars,mode)
  1420. else typerr(car u,"operator")
  1421. else if not idp car u then typerr(car u,"operator")
  1422. else if get(car u, 'localfnname)
  1423. then return form1(get(car u,'localfnname) . cdr u,vars,mode)
  1424. else if flagp(car u,'noform) then return u
  1425. else if arrayp car u
  1426. and (mode eq 'symbolic or intexprlisp(cdr u,vars))
  1427. then return list('getel,intargfn(u,vars,mode))
  1428. else if flagp(car u,'modefn)
  1429. then return convertmode(cadr u,vars,mode,car u)
  1430. else if (x := get(car u,'formfn))
  1431. then return macrochk(apply(x,list(u,vars,mode)),mode)
  1432. else if get(car u,'stat) eq 'rlis
  1433. then return macrochk(formrlis(u,vars,mode),mode)
  1434. % else if (x := getd car u) and eqcar(x, 'macro) and
  1435. % not(mode eq 'algebraic) then
  1436. % return << x := apply(cdr x, list(u, vars, mode));
  1437. % formc(x, vars, mode) >>
  1438. ;
  1439. argnochk u;
  1440. x := formlis(cdr u,vars,mode);
  1441. y := if x=cdr u then u else car u . x;
  1442. return if mode eq 'symbolic
  1443. or get(car u,'stat)
  1444. or cdr u and eqcar(cadr u,'quote)
  1445. and null !*micro!-version
  1446. or intexprnp(y,vars) and null !*composites
  1447. and null current!-modulus
  1448. then macrochk(y,mode)
  1449. else if not(mode eq 'algebraic)
  1450. then convertmode(y,vars,mode,'algebraic)
  1451. else ('list . algid(car u,vars) . x)
  1452. end;
  1453. symbolic procedure argnochk u;
  1454. begin scalar x;
  1455. if null !*argnochk then nil
  1456. else if (x := argsofopr car u) and x neq length cdr u
  1457. then rederr list(car u,"called with",
  1458. length cdr u,
  1459. if length cdr u=1 then "argument"
  1460. else "arguments",
  1461. "instead of",x)
  1462. end;
  1463. symbolic procedure argsofopr u;
  1464. % This function may be optimizable in various implementations.
  1465. get(u,'number!-of!-args);
  1466. symbolic procedure intexprnp(u,vars);
  1467. %determines if U is an integer expression;
  1468. if atom u then if numberp u then fixp u
  1469. else if (u := atsoc(u,vars)) then cdr u eq 'integer
  1470. else nil
  1471. else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars);
  1472. symbolic procedure intexprlisp(u,vars);
  1473. null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars);
  1474. flag('(difference minus plus times),'intfn);
  1475. % EXPT is not included in this list, because a negative exponent can
  1476. % cause problems (i.e., result can be rational);
  1477. symbolic procedure formlis(u,vars,mode);
  1478. mapcar(u,function (lambda x; form1(x,vars,mode)));
  1479. symbolic procedure formclis(u,vars,mode);
  1480. mapcar(u,function (lambda x; formc(x,vars,mode)));
  1481. symbolic procedure form u; form1(u,!*vars!*,!*mode);
  1482. symbolic procedure macrochk(u,mode);
  1483. begin scalar y;
  1484. %expands U if CAR U is a macro and expansion allowed;
  1485. if atom u then return u
  1486. else if (y := expdrmacro car u)
  1487. and (mode eq 'symbolic or idp car u and flagp(car u,'opfn))
  1488. then return apply(get(car y,'macrofn),list(cdr y,cdr u,car u))
  1489. else return u
  1490. end;
  1491. put('symbolic,'idfn,'symbid);
  1492. symbolic procedure symbid(u,vars); u;
  1493. % if atsoc(u,vars) or fluidp u or globalp u or u memq '(nil t)
  1494. % or flagp(u,'share) then u
  1495. % else <<lprim list(u,"Non-Local Identifier");% u>>;
  1496. put('algebraic,'idfn,'algid);
  1497. symbolic procedure algid(u,vars);
  1498. if atsoc(u,vars) or flagp(u,'share) then u else mkquote u;
  1499. put('integer,'idfn,'intid);
  1500. symbolic procedure intid(u,vars);
  1501. begin scalar x,y;
  1502. return if (x := atsoc(u,vars))
  1503. then if cdr x eq 'integer then u
  1504. else if y := get(cdr x,'integer)
  1505. then apply2(y,u,vars)
  1506. else if cdr x eq 'scalar then !*!*a2i(u,vars)
  1507. else rederr list(cdr x,"not convertable to INTEGER")
  1508. else !*!*a2i(mkquote u,vars)
  1509. end;
  1510. symbolic procedure convertmode(exprn,vars,target,source);
  1511. convertmode1(form1(exprn,vars,source),vars,target,source);
  1512. symbolic procedure convertmode1(exprn,vars,target,source);
  1513. begin scalar x;
  1514. if source eq 'real then source := 'algebraic;
  1515. if target eq 'real then target := 'algebraic;
  1516. if target eq source then return exprn
  1517. else if idp exprn and (x := atsoc(exprn,vars))
  1518. and not(cdr x memq '(integer scalar real))
  1519. and not(cdr x eq source)
  1520. then return convertmode(exprn,vars,target,cdr x)
  1521. else if not (x := get(source,target))
  1522. then typerr(source,target)
  1523. else return apply2(x,exprn,vars)
  1524. end;
  1525. put('algebraic,'symbolic,'!*!*a2s);
  1526. put('symbolic,'algebraic,'!*!*s2a);
  1527. symbolic procedure !*!*a2s(u,vars);
  1528. % It would be nice if we could include the ATSOC(U,VARS) line,
  1529. % since in many cases that would save recomputation. However,
  1530. % in any sequential process, assignments or subsititution rules
  1531. % can change the value of a variable, so we have to check its
  1532. % value again. More comprehensive analysis could certainly
  1533. % optimize this.
  1534. if u = '(quote nil) then nil
  1535. else if null u or constantp u and null fixp u
  1536. or intexprnp(u,vars) and null !*composites
  1537. and null current!-modulus
  1538. or not atom u and idp car u
  1539. and flagp(car u,'nochange) and not(car u eq 'getel)
  1540. % or atsoc(u,vars) % means it was already evaluated
  1541. then u
  1542. else list(!*!*a2sfn,u);
  1543. symbolic procedure !*!*s2a(u,vars); u;
  1544. symbolic procedure formc(u,vars,mode);
  1545. %this needs to be generalized;
  1546. if mode eq 'algebraic and intexprnp(u,vars) then u
  1547. else convertmode(u,vars,'symbolic,mode);
  1548. symbolic procedure intargfn(u,vars,mode);
  1549. % transforms array element U into expression with integer arguments.
  1550. % Array name is treated as an algebraic variable;
  1551. 'list . form1(car u,vars,'algebraic) .
  1552. mapcar(cdr u,
  1553. function (lambda x;
  1554. convertmode(x,vars,'integer,mode)));
  1555. put('algebraic,'integer,'!*!*a2i);
  1556. symbolic procedure !*!*a2i(u,vars);
  1557. if intexprnp(u,vars) then u else list('ieval,u);
  1558. symbolic procedure ieval u; !*s2i reval u;
  1559. flag('(ieval),'opfn); % To make it a symbolic operator.
  1560. flag('(ieval),'nochange);
  1561. put('symbolic,'integer,'!*!*s2i);
  1562. symbolic procedure !*!*s2i(u,vars);
  1563. if fixp u then u else list('!*s2i,u);
  1564. symbolic procedure !*s2i u;
  1565. if fixp u then u else typerr(u,"integer");
  1566. put('integer,'symbolic,'identity);
  1567. symbolic procedure identity(u,vars); u;
  1568. symbolic procedure formbool(u,vars,mode);
  1569. if mode eq 'symbolic then form1(u,vars,mode)
  1570. else if atom u then if not idp u or atsoc(u,vars) or u eq 't
  1571. then u
  1572. else formc!*(u,vars,mode)
  1573. else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u
  1574. else if idp car u and get(car u,'boolfn)
  1575. then get(car u,'boolfn) . formclis(cdr u,vars,mode)
  1576. else if idp car u and flagp(car u,'boolean)
  1577. then car u .
  1578. mapcar(cdr u,function (lambda x;
  1579. if flagp(car u,'boolargs)
  1580. then formbool(x,vars,mode)
  1581. else formc!*(x,vars,mode)))
  1582. else formc!*(u,vars,mode);
  1583. symbolic procedure formc!*(u,vars,mode);
  1584. begin scalar !*!*a2sfn;
  1585. !*!*a2sfn := 'reval;
  1586. return formc(u,vars,mode)
  1587. end;
  1588. % Functions with side effects must be handled carefully in this model,
  1589. % otherwise they are not always evaluated within blocks.
  1590. symbolic procedure formrederr(u,vars,mode);
  1591. begin scalar x;
  1592. x := formc!*(cadr u,vars,mode);
  1593. return list('rederr,x)
  1594. end;
  1595. put('rederr,'formfn,'formrederr);
  1596. symbolic procedure formreturn(u,vars,mode);
  1597. begin scalar x;
  1598. x := form1(cadr u,vars,mode); % FORMC here would add REVAL
  1599. if not(mode memq '(symbolic integer real))
  1600. and eqcar(x,'setq) % Should this be more general?
  1601. then x := list(!*!*a2sfn,x);
  1602. return list('return,x)
  1603. end;
  1604. put('return,'formfn,'formreturn);
  1605. symbolic procedure formsetq(u,vars,mode);
  1606. begin scalar target,x,y;
  1607. u := cdr u;
  1608. if eqcar(cadr u,'quote) then mode := 'symbolic;
  1609. if idp car u
  1610. and (y := atsoc(car u,vars)) and not(cdr y eq 'scalar)
  1611. then target := 'symbolic % used to be CDR Y
  1612. else target := 'symbolic;
  1613. % Make target always SYMBOLIC so that algebraic expressions
  1614. % are evaluated before being stored.
  1615. x := convertmode(cadr u,vars,target,mode);
  1616. return if not atom car u
  1617. then if not idp caar u then typerr(car u,"assignment")
  1618. else if arrayp caar u
  1619. then list('setel,intargfn(car u,vars,mode),x)
  1620. else if y := get(caar u,'setqfn)
  1621. then form1((y . append(cdar u,cdr u)),vars,mode)
  1622. % else if y := get(caar u, 'access)
  1623. % then list('m!-setf,
  1624. % list(caar u, form1(cadar u, vars, mode)),
  1625. % x)
  1626. else list('setk,form1(car u,vars,'algebraic),x)
  1627. % algebraic needed above, since SETK expects it.
  1628. else if not idp car u then typerr(car u,"assignment")
  1629. else if mode eq 'symbolic or y or flagp(car u,'share)
  1630. or eqcar(x,'quote)
  1631. then mksetq(car u,x)
  1632. else list('setk,mkquote car u,x)
  1633. end;
  1634. put('car,'setqfn,'rplaca);
  1635. put('cdr,'setqfn,'rplacd);
  1636. put('setq,'formfn,'formsetq);
  1637. symbolic procedure formfunc(u,vars,mode);
  1638. if idp cadr u then if getrmacro cadr u
  1639. then rederr list("Macro",cadr u,"Used as Function")
  1640. else list('function,cadr u)
  1641. else list('function,form1(cadr u,vars,mode));
  1642. put('function,'formfn,'formfunc);
  1643. % RLIS is a parser function that reads a list of arguments and returns
  1644. % this list as one argument. It needs to be defined in this module for
  1645. % bootstrapping purposes since this definition only works with its form
  1646. % function.
  1647. symbolic procedure rlis;
  1648. begin scalar x;
  1649. x := cursym!*;
  1650. return if flagp!*!*(scan(),'delim) then list(x,nil)
  1651. else x . remcomma xread1 'lambda
  1652. end;
  1653. symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end;
  1654. symbolic procedure rlistat u;
  1655. begin
  1656. a: if null u then return nil;
  1657. put(car u,'stat,'rlis);
  1658. u := cdr u;
  1659. go to a
  1660. end;
  1661. rlistat '(flagop);
  1662. symbolic procedure formrlis(u,vars,mode);
  1663. if not flagp(car u,'flagop)
  1664. then list(car u,'list . formlis(cdr u,vars,'algebraic))
  1665. else if not idlistp cdr u
  1666. then typerr('!*comma!* . cdr u,"identifier list")
  1667. else mkprog(nil,list('flag,mkquote cdr u,mkquote car u)
  1668. . get(car u,'simpfg));
  1669. symbolic procedure mkarg(u,vars);
  1670. % Returns the "unevaled" form of U.
  1671. if null u or constantp u then u
  1672. else if atom u then if atsoc(u,vars) then u else mkquote u
  1673. else if car u eq 'quote then mkquote u
  1674. else 'list . mapcar(u,function (lambda x; mkarg(x,vars)));
  1675. endmodule;
  1676. module proc; % Procedure statement.
  1677. % Author: Anthony C. Hearn.
  1678. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  1679. fluid '(!*backtrace);
  1680. global '(!*argnochk !*comp !*lose cursym!* erfg!* fname!* ftypes!*);
  1681. fluid '(!*defn);
  1682. !*lose := t;
  1683. ftypes!* := '(expr fexpr macro);
  1684. symbolic procedure putc(name,type,body);
  1685. %defines a non-standard function, such as an smacro. Returns NAME;
  1686. begin
  1687. if !*comp and flagp(type,'compile) then compd(name,type,body)
  1688. else put(name,type,body);
  1689. return name
  1690. end;
  1691. % flag('(putc),'eval);
  1692. symbolic procedure formproc(u,vars,mode);
  1693. begin scalar body,name,type,varlis,x,y;
  1694. u := cdr u;
  1695. name := car u;
  1696. if cadr u then mode := cadr u; % overwrite previous mode
  1697. u := cddr u;
  1698. type := car u;
  1699. if flagp(name,'lose) and (!*lose or null !*defn)
  1700. then return progn(lprim list(name,
  1701. "not defined (LOSE flag)"),
  1702. nil);
  1703. varlis := cadr u;
  1704. u := caddr u;
  1705. x := if eqcar(u,'block) then cadr u else nil;
  1706. y := pairxvars(varlis,x,vars,mode);
  1707. if x then u := car u . rplaca!*(cdr u,cdr y);
  1708. body:= form1(u,car y,mode); % FORMC here would add REVAL
  1709. if type eq 'expr then body := list('de,name,varlis,body)
  1710. else if type eq 'fexpr then body := list('df,name,varlis,body)
  1711. else if type eq 'macro then body := list('dm,name,varlis,body)
  1712. else if type eq 'emb then return embfn(name,varlis,body)
  1713. else body := list('putc,
  1714. mkquote name,
  1715. mkquote type,
  1716. mkquote list('lambda,varlis,body));
  1717. if not(mode eq 'symbolic)
  1718. then body := list('progn,
  1719. list('flag,mkquote list name,mkquote 'opfn),
  1720. body);
  1721. if !*argnochk and type memq '(expr smacro)
  1722. then body := list('progn,
  1723. list('put,mkquote name,
  1724. mkquote 'number!-of!-args,
  1725. length varlis),
  1726. body);
  1727. if !*defn and type memq '(fexpr macro smacro) then eval body;
  1728. return body
  1729. end;
  1730. put('procedure,'formfn,'formproc);
  1731. symbolic procedure pairxvars(u,v,vars,mode);
  1732. %Pairs procedure variables and their modes, taking into account
  1733. %the convention which allows a top level prog to change the mode
  1734. %of such a variable;
  1735. begin scalar x,y;
  1736. a: if null u then return append(reversip!* x,vars) . v
  1737. else if (y := atsoc(car u,v))
  1738. then <<v := delete(y,v);
  1739. if not(cdr y eq 'scalar) then x := (car u . cdr y) . x
  1740. else x := (car u . mode) . x>>
  1741. else x := (car u . mode) . x;
  1742. u := cdr u;
  1743. go to a
  1744. end;
  1745. symbolic procedure procstat1 mode;
  1746. begin scalar bool,u,type,x,y,z;
  1747. bool := erfg!*;
  1748. if fname!* then go to b
  1749. else if cursym!* eq 'procedure then type := 'expr
  1750. else progn(type := cursym!*,scan());
  1751. if not cursym!* eq 'procedure then go to c;
  1752. x := errorset('(xread (quote proc)),nil,!*backtrace);
  1753. if errorp x then go to a
  1754. else if atom (x := car x) then x := list x; %no arguments;
  1755. fname!* := car x; %function name;
  1756. if idp fname!* %AND NOT(TYPE MEMQ FTYPES!*);
  1757. then if null fname!* or (z := gettype fname!*)
  1758. and not z memq '(procedure operator)
  1759. then go to d
  1760. else if not getd fname!* then flag(list fname!*,'fnc);
  1761. %to prevent invalid use of function name in body;
  1762. u := cdr x;
  1763. y := u;
  1764. x := car x . y;
  1765. a: z := errorset('(xread t),nil,!*backtrace);
  1766. if not errorp z then z := car z;
  1767. if null erfg!* then z:=list('procedure,car x,mode,type,y,z);
  1768. remflag(list fname!*,'fnc);
  1769. fname!*:=nil;
  1770. if erfg!* then progn(z := nil,if not bool then error1());
  1771. return z;
  1772. b: bool := t;
  1773. c: errorset('(symerr (quote procedure) t),nil,!*backtrace);
  1774. go to a;
  1775. d: typerr(list(z,fname!*),"procedure");
  1776. go to a
  1777. end;
  1778. symbolic procedure procstat; procstat1 nil;
  1779. deflist ('((procedure procstat) (expr procstat) (fexpr procstat)
  1780. (emb procstat) (macro procstat) (smacro procstat)),
  1781. 'stat);
  1782. % Next line refers to bootstrapping process.
  1783. if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat);
  1784. deflist('((lisp symbolic)),'newnam);
  1785. endmodule;
  1786. module forstat; % Definition of REDUCE FOR loops.
  1787. % Author: Anthony C. Hearn.
  1788. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  1789. fluid '(!*blockp);
  1790. global '(cursym!* foractions!*);
  1791. comment the syntax of the FOR statement is as follows:
  1792. {step i3 until}
  1793. {i := i1 { } i2 }
  1794. { { : } }
  1795. for { } <action> <expr>
  1796. { { in } }
  1797. { each i { } <list> }
  1798. { on }
  1799. In all cases, the <expr> is evaluated algebraically within the scope of
  1800. the current value of i. If <action> is DO, then nothing else happens.
  1801. In other cases, <action> is a binary operator that causes a result to be
  1802. built up and returned by FOR. In each case, the loop is initialized to
  1803. a default value. The test for the end condition is made before any
  1804. action is taken.
  1805. The effect of the definition here is to replace all for loops by
  1806. semantically equivalent blocks. As a result, none of the mapping
  1807. functions are needed in REDUCE.
  1808. To declare a set of actions, one says;
  1809. foractions!* := '(do collect conc product sum);
  1810. remflag(foractions!*,'delim); % For bootstrapping purposes.
  1811. % To associate a binary function with an action, one says:
  1812. deflist('((product times) (sum plus)),'bin);
  1813. % And to give these an initial value in a loop:
  1814. deflist('((product 1) (sum 0)),'initval);
  1815. % NB: We need to reset for and let delims if an error occurs. It's
  1816. % probably best to do this in the begin1 loop.
  1817. flag('(for),'nochange);
  1818. symbolic procedure forstat;
  1819. begin scalar !*blockp;
  1820. return if scan() eq 'all then forallstat()
  1821. else if cursym!* eq 'each then foreachstat()
  1822. else forloop()
  1823. end;
  1824. put('for,'stat,'forstat);
  1825. symbolic procedure forloop;
  1826. begin scalar action,bool,incr,var,x;
  1827. flag('(step),'delim);
  1828. x := errorset('(xread1 'for),t,t);
  1829. remflag('(step),'delim);
  1830. if errorp x then error1() else x := car x;
  1831. if not eqcar(x,'setq) or not idp(var := cadr x)
  1832. then symerr('for,t);
  1833. x := caddr x;
  1834. if cursym!* eq 'step
  1835. then <<flag('(until),'delim);
  1836. incr := xread t;
  1837. remflag('(until),'delim);
  1838. if not cursym!* eq 'until then symerr('for,t)>>
  1839. else if cursym!* eq '!*colon!* then incr := 1
  1840. else symerr('for,t);
  1841. if flagp(car foractions!*,'delim) then bool := t % nested loop
  1842. else flag(foractions!*,'delim);
  1843. incr := list(x,incr,xread t);
  1844. if null bool then remflag(foractions!*,'delim);
  1845. if not((action := cursym!*) memq foractions!*)
  1846. then symerr('for,t);
  1847. return list('for,var,incr,action,xread t)
  1848. end;
  1849. symbolic procedure formfor(u,vars,mode);
  1850. begin scalar action,algp,body,endval,incr,initval,var,x;
  1851. %ALGP is used to determine if the loop calculation must be
  1852. %done algebraically or not;
  1853. var := cadr u;
  1854. incr := caddr u;
  1855. incr := list(formc(car incr,vars,mode),
  1856. formc(cadr incr,vars,mode),
  1857. formc(caddr incr,vars,mode));
  1858. if intexprnp(car incr,vars) and intexprnp(cadr incr,vars)
  1859. and not atsoc(var,vars)
  1860. then vars := (var . 'integer) . vars;
  1861. action := cadddr u;
  1862. body :=
  1863. formc(car cddddr u,
  1864. (var .
  1865. if intexprlisp(caddr u,vars) then 'integer else mode)
  1866. . vars,mode);
  1867. algp := algmodep car incr or algmodep cadr incr
  1868. or algmodep caddr incr;
  1869. initval := car incr;
  1870. endval := caddr incr;
  1871. incr := cadr incr;
  1872. x := if algp then list('list,''difference,endval,var)
  1873. else list('difference,endval,var);
  1874. if incr neq 1
  1875. then x := if algp then list('list,''times,incr,x)
  1876. else list('times,incr,x);
  1877. % We could consider simplifying X here (via reval).
  1878. x := if algp then list('aminusp!:,x) else list('minusp,x);
  1879. return forformat(action,body,initval,x,
  1880. list('plus2,incr),var,vars,mode)
  1881. end;
  1882. put('for,'formfn,'formfor);
  1883. symbolic procedure algmodep u; eqcar(u,'aeval);
  1884. symbolic procedure aminusp!: u;
  1885. begin scalar x;
  1886. u := aeval u;
  1887. x := u;
  1888. if fixp x then return minusp x
  1889. else if not eqcar(x,'!*sq)
  1890. then msgpri(nil,reval u,"invalid in FOR statement",nil,t);
  1891. x := cadr x;
  1892. if fixp car x and fixp cdr x then return minusp car x
  1893. else if not cdr x = 1
  1894. or not (atom(x := car x) or atom car x)
  1895. % Should be DOMAINP, but SMACROs not yet defined.
  1896. then msgpri(nil,reval u,"invalid in FOR statement",nil,t)
  1897. else return apply('!:minusp,list x)
  1898. end;
  1899. symbolic procedure foreachstat;
  1900. begin scalar w,x,y,z;
  1901. if not idp(x := scan()) or not (y := scan()) memq '(in on)
  1902. then symerr("FOR EACH",t)
  1903. else if flagp(car foractions!*,'delim) then w := t
  1904. else flag(foractions!*,'delim);
  1905. z := xread t;
  1906. if null w then remflag(foractions!*,'delim);
  1907. w := cursym!*;
  1908. if not w memq foractions!* then symerr("FOR EACH",t);
  1909. return list('foreach,x,y,z,w,xread t)
  1910. end;
  1911. put('foreach,'stat,'foreachstat);
  1912. symbolic procedure formforeach(u,vars,mode);
  1913. begin scalar action,body,lst,mod,var;
  1914. var := cadr u; u := cddr u;
  1915. mod := car u; u := cdr u;
  1916. lst := formc(car u,vars,mode); u := cdr u;
  1917. if not(mode eq 'symbolic) then lst := list('getrlist,lst);
  1918. action := car u; u := cdr u;
  1919. body := formc(car u,(var . mode) . vars,mode);
  1920. if mod eq 'in
  1921. then body := list(list('lambda,list var,body),list('car,var))
  1922. else if not(mode eq 'symbolic) then typerr(mod,'action);
  1923. return forformat(action,body,lst,
  1924. list('null,var),list 'cdr,var,vars,mode)
  1925. end;
  1926. put('foreach,'formfn,'formforeach);
  1927. symbolic procedure forformat(action,body,initval,
  1928. testexp,updform,var,vars,mode);
  1929. begin scalar result;
  1930. result := gensym();
  1931. return
  1932. sublis(list('body2 .
  1933. if mode eq 'symbolic or intexprnp(body,vars)
  1934. then list(get(action,'bin),body,result)
  1935. else list('aeval,list('list,mkquote get(action,'bin),
  1936. body,result)),
  1937. 'body3 .
  1938. if mode eq 'symbolic then body
  1939. else list('getrlist,body),
  1940. 'body . body,
  1941. 'initval . initval,
  1942. 'nillist . if mode eq 'symbolic then nil else ''(list),
  1943. 'result . result,
  1944. 'initresult . get(action,'initval),
  1945. 'resultlist . if mode eq 'symbolic then result
  1946. else list('cons,''list,result),
  1947. 'testexp . testexp,
  1948. 'updfn . car updform,
  1949. 'updval . cdr updform,
  1950. 'var . var),
  1951. if action eq 'do
  1952. then '(prog (var)
  1953. (setq var initval)
  1954. lab (cond (testexp (return nil)))
  1955. body
  1956. (setq var (updfn var . updval))
  1957. (go lab))
  1958. else if action eq 'collect
  1959. then '(prog (var result endptr)
  1960. (setq var initval)
  1961. (cond (testexp (return nillist)))
  1962. (setq result (setq endptr (cons body nil)))
  1963. looplabel
  1964. (setq var (updfn var . updval))
  1965. (cond (testexp (return resultlist)))
  1966. (rplacd endptr (cons body nil))
  1967. (setq endptr (cdr endptr))
  1968. (go looplabel))
  1969. else if action eq 'conc
  1970. then '(prog (var result endptr)
  1971. (setq var initval)
  1972. startover
  1973. (cond (testexp (return nillist)))
  1974. (setq result body)
  1975. (setq endptr (lastpair resultlist))
  1976. (setq var (updfn var . updval))
  1977. (cond ((atom endptr) (go startover)))
  1978. looplabel
  1979. (cond (testexp (return result)))
  1980. (rplacd endptr body3)
  1981. (setq endptr (lastpair endptr))
  1982. (setq var (updfn var . updval))
  1983. (go looplabel))
  1984. else '(prog (var result)
  1985. (setq var initval)
  1986. (setq result initresult)
  1987. lab1
  1988. (cond (testexp (return result)))
  1989. (setq result body2)
  1990. (setq var (updfn var . updval))
  1991. (go lab1)))
  1992. end;
  1993. symbolic procedure lastpair u;
  1994. % Return the last pair of the list u.
  1995. if atom u or atom cdr u then u else lastpair cdr u;
  1996. put('join,'newnam,'conc); % alternative for CONC
  1997. endmodule;
  1998. module loops; % Looping forms other than the FOR statement.
  1999. % Author: Anthony C. Hearn
  2000. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2001. fluid '(!*blockp);
  2002. global '(cursym!*);
  2003. % ***** REPEAT STATEMENT *****
  2004. symbolic procedure repeatstat;
  2005. begin scalar body,!*blockp;
  2006. flag('(until),'delim);
  2007. body:= xread t;
  2008. remflag('(until),'delim);
  2009. if not cursym!* eq 'until then symerr('repeat,t);
  2010. return list('repeat,body,xread t);
  2011. end;
  2012. symbolic macro procedure repeat u;
  2013. begin scalar body,bool,lab;
  2014. body := cadr u; bool := caddr u;
  2015. lab := gensym();
  2016. return mkprog(nil,list(lab,body,
  2017. list('cond,list(list('not,bool),list('go,lab)))))
  2018. end;
  2019. put('repeat,'stat,'repeatstat);
  2020. flag('(repeat),'nochange);
  2021. symbolic procedure formrepeat(u,vars,mode);
  2022. list('repeat,formc(cadr u,vars,mode),formbool(caddr u,vars,mode));
  2023. put('repeat,'formfn,'formrepeat);
  2024. % ***** WHILE STATEMENT *****
  2025. symbolic procedure whilstat;
  2026. begin scalar bool,!*blockp;
  2027. flag('(do),'delim);
  2028. bool := xread t;
  2029. remflag('(do),'delim);
  2030. if not cursym!* eq 'do then symerr('while,t);
  2031. return list('while,bool,xread t)
  2032. end;
  2033. symbolic macro procedure while u;
  2034. begin scalar body,bool,lab;
  2035. bool := cadr u; body := caddr u;
  2036. lab := gensym();
  2037. return mkprog(nil,list(lab,list('cond,list(list('not,bool),
  2038. list('return,nil))),body,list('go,lab)))
  2039. end;
  2040. put('while,'stat,'whilstat);
  2041. flag('(while),'nochange);
  2042. symbolic procedure formwhile(u,vars,mode);
  2043. list('while,formbool(cadr u,vars,mode),formc(caddr u,vars,mode));
  2044. put('while,'formfn,'formwhile);
  2045. endmodule;
  2046. module write; % Miscellaneous statement definitions.
  2047. % Author: Anthony C. Hearn.
  2048. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2049. % ***** DEFINE STATEMENT *****
  2050. remprop('define,'stat);
  2051. symbolic procedure define u;
  2052. for each x in u do
  2053. if not eqcar(x,'equal) or not idp cadr x
  2054. then typerr(x,"DEFINE declaration")
  2055. else put(cadr x,'newnam,caddr x);
  2056. put('define,'stat,'rlis);
  2057. flag('(define),'eval);
  2058. % ***** WRITE STATEMENT *****
  2059. symbolic procedure formwrite(u,vars,mode);
  2060. begin scalar bool1,bool2,x,z;
  2061. u := cdr u;
  2062. bool1 := mode eq 'symbolic;
  2063. while u do
  2064. <<x := formc(car u,vars,mode);
  2065. z := (if bool1 then list('prin2,x)
  2066. else list('writepri,mkarg1(x,vars),
  2067. if not cdr u then if not bool2 then ''only else ''last
  2068. else if not bool2 then ''first else nil)) .
  2069. z;
  2070. bool2 := t;
  2071. u := cdr u>>;
  2072. return mkprog(nil,reversip!* z)
  2073. end;
  2074. symbolic procedure writepri(u,v);
  2075. begin scalar x; x := assgneval u; return varpri(car x,cdr x,v) end;
  2076. symbolic procedure mkarg1(u,vars);
  2077. % Returns the "unevaled" form of U for the WRITE command.
  2078. if null u or constantp u then u
  2079. else if atom u then if atsoc(u,vars)
  2080. then list('mkquote,u) else mkquote u
  2081. else if car u eq 'quote then mkquote u
  2082. else if car u eq 'setq
  2083. then list('list,''setq,mkquote cadr u,mkarg1(caddr u,vars))
  2084. else 'list . mapcar(u,function (lambda x; mkarg1(x,vars)));
  2085. put('write,'stat,'rlis);
  2086. put('write,'formfn,'formwrite);
  2087. endmodule;
  2088. module smacro; % Support for SMACRO expansion.
  2089. % Author: Anthony C. Hearn.
  2090. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2091. symbolic procedure applsmacro(u,vals,name);
  2092. % U is smacro body of form (lambda <varlist> <body>), VALS is
  2093. % argument list, NAME is name of smacro.
  2094. begin scalar body,remvars,varlist,w;
  2095. varlist := cadr u;
  2096. body := caddr u;
  2097. if length varlist neq length vals
  2098. then rederr list("Argument mismatch for SMACRO",name);
  2099. if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body)
  2100. then return subla!-q(pair(varlist,vals),body)
  2101. else if length varlist>1
  2102. then <<w := for each x in varlist collect (x . gensym());
  2103. body := subla!-q(w,body);
  2104. varlist := for each x in w collect cdr x>>;
  2105. for each x in vals do
  2106. <<if no!-side!-effectp x or one!-entryp(car varlist,body)
  2107. then body := subla!-q(list(car varlist . x),body)
  2108. else remvars := aconc(remvars,car varlist . x);
  2109. varlist := cdr varlist>>;
  2110. if null remvars then return body
  2111. else <<w := list('lambda,
  2112. for each x in remvars collect car x,
  2113. body) .
  2114. for each x in remvars collect cdr x;
  2115. % IF NOT EQCAR(CADR W,'SETQ)
  2116. % THEN <<PRIN2 "*** SMACRO: "; PRINT CDR W>>;
  2117. return w>>
  2118. end;
  2119. symbolic procedure no!-side!-effectp u;
  2120. if atom u then numberp u or idp u and not(fluidp u or globalp u)
  2121. else if car u eq 'quote then t
  2122. else if flagp!*!*(car u,'nosideeffects)
  2123. then no!-side!-effect!-listp u
  2124. else nil;
  2125. symbolic procedure no!-side!-effect!-listp u;
  2126. null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u;
  2127. flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
  2128. cddar cdddr cons),'nosideeffects);
  2129. symbolic procedure one!-entryp(u,v);
  2130. % determines if id U occurs less than twice in V.
  2131. if atom v then t
  2132. else if smemq(u,car v)
  2133. then if smemq(u,cdr v) then nil else one!-entryp(u,car v)
  2134. else one!-entryp(u,cdr v);
  2135. symbolic procedure one!-entry!-listp(u,v);
  2136. null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v);
  2137. symbolic procedure subla!-q(u,v);
  2138. begin scalar x;
  2139. if null u or null v then return v
  2140. else if atom v
  2141. then return if x:= atsoc(v,u) then cdr x else v
  2142. else if car v eq 'quote then return v
  2143. else return(subla!-q(u,car v) . subla!-q(u,cdr v))
  2144. end;
  2145. endmodule;
  2146. module infix; % Functions for introducing new infix operators.
  2147. % Author: Anthony C. Hearn.
  2148. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2149. fluid '(!*mode);
  2150. global '(preclis!*);
  2151. symbolic procedure infix x;
  2152. begin scalar y;
  2153. a: if null x then go to b;
  2154. y := car x;
  2155. if !*mode eq 'algebraic then mkop y;
  2156. if not(y member preclis!*) then preclis!* := y . preclis!*;
  2157. x := cdr x;
  2158. go to a;
  2159. b: mkprec()
  2160. end;
  2161. symbolic procedure precedence u;
  2162. begin scalar x,y,z;
  2163. preclis!* := delete(car u,preclis!*);
  2164. y := cadr u;
  2165. x := preclis!*;
  2166. a: if null x then rederr list (y,"not found")
  2167. else if y eq car x
  2168. then <<preclis!* :=
  2169. nconc!*(reversip!* z,car x . (car u . cdr x));
  2170. mkprec();
  2171. return nil>>;
  2172. z := car x . z;
  2173. x := cdr x;
  2174. go to a
  2175. end;
  2176. deflist('((infix rlis) (precedence rlis)),'stat);
  2177. flag('(infix precedence),'eval);
  2178. endmodule;
  2179. module where; % Support for a where construct.
  2180. % Author: Anthony C. Hearn.
  2181. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2182. symbolic procedure formwhere(u,vars,mode);
  2183. begin scalar expn,equivs,y,z;
  2184. expn := cadr u;
  2185. equivs := caddr u;
  2186. if eqcar(equivs,'!*comma!*) then equivs := cdr equivs
  2187. else equivs := list equivs;
  2188. for each x in equivs do
  2189. if not atom x and car x memq '(equal setq)
  2190. then <<y := caddr x . y; z := cadr x . z>>
  2191. else rederr list(x,"invalid in WHERE statement");
  2192. return formc(list('lambda,reversip z,expn) . reversip y,
  2193. vars,mode)
  2194. end;
  2195. put('where,'formfn,'formwhere);
  2196. % infix where; % We do this explicitly to avoid changing preclis*.
  2197. deflist('((where 1)),'infix);
  2198. put('where,'op,'((1 1)));
  2199. endmodule;
  2200. module list; % Define a list as a list of expressions in curly brackets.
  2201. % Author: Anthony C. Hearn.
  2202. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2203. global '(cursym!* orig!* posn!*);
  2204. % Add to system table.
  2205. put('list,'tag,'list);
  2206. put('list,'rtypefn,'(lambda (x) 'list));
  2207. % Parsing interface.
  2208. symbolic procedure xreadlist;
  2209. % expects a list of expressions enclosed by {, }.
  2210. % also allows expressions separated by ; --- treats these as progn.
  2211. begin scalar cursym,delim,lst;
  2212. if scan() eq '!*rcbkt!* then <<scan(); return list 'list>>;
  2213. a: lst := aconc(lst,xread1 'group);
  2214. cursym := cursym!*;
  2215. scan();
  2216. if cursym eq '!*rcbkt!*
  2217. then return if delim eq '!*semicol!* then 'progn . lst
  2218. else 'list . lst
  2219. else if null delim then delim := cursym
  2220. else if not(delim eq cursym)
  2221. then symerr("syntax error: mixed , and ; in list",nil);
  2222. go to a
  2223. end;
  2224. put('!*lcbkt!*,'stat,'xreadlist);
  2225. newtok '((!{) !*lcbkt!*);
  2226. newtok '((!}) !*rcbkt!*);
  2227. flag('(!*rcbkt!*),'delim);
  2228. flag('(!*rcbkt!*),'nodel);
  2229. % Evaluation interface.
  2230. put('list,'evfn,'listeval);
  2231. symbolic procedure getrlist u;
  2232. if eqcar(u,'list) then cdr u
  2233. else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list");
  2234. symbolic procedure listeval(u,v);
  2235. if atom u then listeval(get(u,'rvalue),v)
  2236. else car u . for each j in cdr u collect reval1(j,v);
  2237. % Length interface.
  2238. put('list,'lengthfn,'(lambda (x) (length (cdr x))));
  2239. % Printing interface.
  2240. put('list,'prifn,'listpri);
  2241. symbolic procedure listpri l;
  2242. % This definition is basically that of INPRINT, except that it
  2243. % decides when to split at the comma by looking at the size of
  2244. % the argument.
  2245. begin scalar orig,split,u;
  2246. u := l;
  2247. l := cdr l;
  2248. prin2!* get('!*lcbkt!*,'prtch);
  2249. % Do it this way so table can change.
  2250. orig := orig!*;
  2251. orig!* := if posn!*<18 then posn!* else orig!*+3;
  2252. if null l then go to b;
  2253. split := treesizep(l,40); % 40 is arbitrary choice.
  2254. a: maprint(negnumberchk car l,0);
  2255. l := cdr l;
  2256. if null l then go to b;
  2257. oprin '!*comma!*;
  2258. if split then terpri!* t;
  2259. go to a;
  2260. b: prin2!* get('!*rcbkt!*,'prtch);
  2261. % terpri!* nil;
  2262. orig!* := orig;
  2263. return u
  2264. end;
  2265. symbolic procedure treesizep(u,n);
  2266. % true if u has recursively more pairs than n.
  2267. treesizep1(u,n)=0;
  2268. symbolic procedure treesizep1(u,n);
  2269. if atom u then n-1
  2270. else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n)
  2271. else 0;
  2272. % Definitions of operations on lists
  2273. symbolic procedure rfirst u;
  2274. <<argnochk ('first . u);
  2275. if null(getrtype(u := reval car u) eq 'list)
  2276. then typerr(u,"list")
  2277. else if null cdr u then parterr(u,1)
  2278. else cadr u>>;
  2279. put('first,'psopfn,'rfirst);
  2280. symbolic procedure parterr(u,v);
  2281. msgpri("Expression",u,"does not have part",v,t);
  2282. symbolic procedure rsecond u;
  2283. <<argnochk ('second . u);
  2284. if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
  2285. else if null cdr u or null cddr u then parterr(u,2)
  2286. else caddr u>>;
  2287. put('second,'psopfn,'rsecond);
  2288. symbolic procedure rthird u;
  2289. <<argnochk ('third . u);
  2290. if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
  2291. else if null cdr u or null cddr u or null cdddr u
  2292. then parterr(u,3)
  2293. else cadddr u>>;
  2294. put('third,'psopfn,'rthird);
  2295. symbolic procedure rrest u;
  2296. <<argnochk ('rest . u);
  2297. if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
  2298. else if null cdr u then typerr(u,"non-empty list")
  2299. else 'list . cddr u>>;
  2300. put('rest,'psopfn,'rrest);
  2301. symbolic procedure rappend u;
  2302. begin scalar x,y;
  2303. argnochk ('append . u);
  2304. if null(getrtype(x := reval car u) eq 'list)
  2305. then typerr(x,"list")
  2306. else if null(getrtype(y := reval cadr u) eq 'list)
  2307. then typerr(y,"list")
  2308. else return 'list .append(cdr x,cdr y)
  2309. end;
  2310. put('append,'psopfn,'rappend);
  2311. symbolic procedure rcons u;
  2312. begin scalar x,y;
  2313. argnochk ('cons . u);
  2314. if (y := getrtype(x := reval cadr u)) eq 'vector
  2315. then return prepsq simpdot u
  2316. else if not(y eq 'list) then typerr(x,"list")
  2317. else return 'list . reval car u . cdr x
  2318. end;
  2319. put('cons,'psopfn,'rcons);
  2320. symbolic procedure rreverse u;
  2321. <<argnochk ('reverse . u);
  2322. if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
  2323. else 'list . reverse cdr u>>;
  2324. put('reverse,'psopfn,'rreverse);
  2325. endmodule;
  2326. module array; % Array statement.
  2327. % Author: Anthony C. Hearn.
  2328. % Modifications by: Nancy Kirkwood.
  2329. % These definitions are very careful about bounds checking. Appropriate
  2330. % optimizations in a given system might really speed things up.
  2331. global '(erfg!*);
  2332. symbolic procedure getel u;
  2333. % Returns the value of the array element U.
  2334. getel1(get(car u,'rvalue),cdr u,get(car u,'dimension));
  2335. symbolic procedure getel1(u,v,dims);
  2336. if length v neq length dims
  2337. then rederr "Incorrect array reference"
  2338. else if null v then u
  2339. else if car v geq car dims then rederr "Array out of bounds"
  2340. else getel1(getv(u,car v),cdr v,cdr dims);
  2341. symbolic procedure setel(u,v);
  2342. % Sets array element U to V and returns V.
  2343. setel1(get(car u,'rvalue),cdr u,v,get(car u,'dimension));
  2344. symbolic procedure setel1(u,v,w,dims);
  2345. if length v neq length dims then rederr "Incorrect array reference"
  2346. else if car v geq car dims then rederr "Array out of bounds"
  2347. else if null cdr v then putv(u,car v,w)
  2348. else setel1(getv(u,car v),cdr v,w,cdr dims);
  2349. symbolic procedure dimension u; get(u,'dimension);
  2350. comment further support for REDUCE arrays;
  2351. symbolic procedure typechk(u,v);
  2352. begin scalar x;
  2353. if (x := gettype u) eq v or x eq 'parameter
  2354. then lprim list(v,u,"REDEFINED")
  2355. else if x then typerr(list(x,u),v)
  2356. end;
  2357. symbolic procedure arrayfn(u,v);
  2358. % U is the defining mode, V a list of lists, assumed syntactically
  2359. % correct. ARRAYFN declares each element as an array unless a
  2360. % semantic mismatch occurs.
  2361. begin scalar y;
  2362. for each x in v do
  2363. <<typechk(car x,'array);
  2364. y := add1lis for each z in cdr x collect eval z;
  2365. if null erfg!*
  2366. then <<put(car x,'rtype,'array);
  2367. put(car x,'rvalue,mkarray(y,u));
  2368. put(car x,'dimension,y)>>>>
  2369. end;
  2370. symbolic procedure add1lis u;
  2371. if null u then nil else (car u+1) . add1lis cdr u;
  2372. symbolic procedure mkarray(u,v);
  2373. %U is a list of positive integers representing array bounds, V
  2374. %the defining mode. Value is an array structure;
  2375. if null u then if v eq 'symbolic then nil else 0
  2376. else begin integer n; scalar x;
  2377. n := car u-1;
  2378. x := mkvect n;
  2379. for i:=0:n do putv(x,i,mkarray(cdr u,v));
  2380. return x
  2381. end;
  2382. rlistat '(array);
  2383. flag ('(array arrayfn),'eval);
  2384. symbolic procedure formarray(u,vars,mode);
  2385. begin scalar x;
  2386. x := cdr u;
  2387. while x do <<if atom x then typerr(x,"Array List")
  2388. else if atom car x or not idp caar x
  2389. or not listp cdar x
  2390. then typerr(car x,"Array declaration");
  2391. x := cdr x>>;
  2392. u := for each z in cdr u collect intargfn(z,vars,mode);
  2393. %ARRAY arguments must be returned as quoted structures;
  2394. return list('arrayfn,mkquote mode,'list . u)
  2395. end;
  2396. symbolic procedure listp u;
  2397. % Returns T if U is a top level list.
  2398. null u or not atom u and listp cdr u;
  2399. put('array,'formfn,'formarray);
  2400. put('array,'rtypefn,'arraychk);
  2401. symbolic procedure arraychk u;
  2402. % If arraychk receives NIL, it means that array name is being used
  2403. % as an identifier. We no longer permit this.
  2404. if null u then 'array else nil;
  2405. % nil;
  2406. put('array,'evfn,'arrayeval);
  2407. symbolic procedure arrayeval(u,v);
  2408. % Eventually we'll support this.
  2409. rederr "Array arithmetic not defined";
  2410. put('array,'lengthfn,'arraylength);
  2411. symbolic procedure arraylength u; 'list . get(u,'dimension);
  2412. endmodule;
  2413. module switch; % Support for switches and ON and OFF statements.
  2414. % Author: Anthony C. Hearn.
  2415. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2416. global '(!*switchcheck switchlist!*);
  2417. % No references to RPLAC-based functions in this module.
  2418. symbolic procedure on u; onoff(u,t);
  2419. symbolic procedure off u; onoff(u,nil);
  2420. symbolic procedure onoff(u,bool);
  2421. for each j in u do
  2422. begin scalar x,y;
  2423. if not idp j then typerr(j,"switch")
  2424. else if not flagp(j,'switch)
  2425. then if !*switchcheck
  2426. then rederr list(j,"not defined as switch")
  2427. else lpriw("*****",list(j,"not defined as switch"));
  2428. x := intern compress append(explode '!*,explode j);
  2429. if !*switchcheck and eval x eq bool then return nil
  2430. else if y := atsoc(bool,get(j,'simpfg))
  2431. then eval mkprog(nil,cdr y);
  2432. set(x,bool)
  2433. end;
  2434. symbolic procedure switch u;
  2435. % Declare list u as switches.
  2436. for each x in u do
  2437. begin scalar y;
  2438. if not idp x then typerr(x,"switch");
  2439. if not u memq switchlist!*
  2440. then switchlist!* := x . switchlist!*;
  2441. flag(list x,'switch);
  2442. y := intern compress append(explode '!*,explode x);
  2443. if not fluidp y and not globalp y then fluid list y
  2444. end;
  2445. deflist('((switch rlis)),'stat); % we use deflist since it's flagged
  2446. % eval
  2447. rlistat '(off on);
  2448. flag ('(off on),'ignore);
  2449. % Symbolic mode switches:
  2450. switch backtrace,comp,defn,demo,echo,errcont,int,msg,output,pret,
  2451. quotenewnam,raise,time; % switchcheck.
  2452. % The following are compiler switches that may not be supported in all
  2453. % versions:
  2454. switch pgwd,plap,pwrds;
  2455. % flag('(switch),'eval);
  2456. endmodule;
  2457. module io; % Reduce functions for handling input and output of files.
  2458. % Author: Anthony C. Hearn.
  2459. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2460. fluid '(!*backtrace !*int semic!*);
  2461. global '(!*echo contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!*
  2462. techo!*);
  2463. symbolic procedure file!-transform(u,v);
  2464. % Performs a transformation on the file u. V is name of function
  2465. % used for the transformation;
  2466. begin scalar echo,ichan,oldichan,val;
  2467. echo := !*echo;
  2468. !*echo := nil;
  2469. ichan := open(u,'input);
  2470. oldichan := rds ichan;
  2471. val := errorset(list v,t,!*backtrace);
  2472. !*echo := echo;
  2473. close ichan;
  2474. rds oldichan;
  2475. if not errorp val then return car val
  2476. end;
  2477. symbolic procedure infile u;
  2478. % loads the single file u into REDUCE without echoing;
  2479. begin scalar !*int;
  2480. return file!-transform(u,function begin1)
  2481. end;
  2482. symbolic procedure in u;
  2483. begin scalar chan,echo,echop,type;
  2484. echop := semic!* eq '!;; %record echo character from input;
  2485. echo := !*echo; %save current echo status;
  2486. if null ifl!* then techo!* := !*echo; %terminal echo status;
  2487. for each fl in u do
  2488. <<if fl eq 't then fl := nil;
  2489. if null fl then <<!*echo := techo!*; rds nil; ifl!* := nil>>
  2490. else <<chan := open(fl := mkfil fl,'input);
  2491. rds chan;
  2492. % if assoc(fl,linelist!*) then nil;
  2493. curline!* := 1;
  2494. ifl!* := list(fl,chan,1)>>;
  2495. ipl!* := ifl!* . ipl!*; %add to input file stack;
  2496. !*echo := echop;
  2497. type := filetype fl;
  2498. if type and (type := get(type,'action)) then eval list type
  2499. else begin1();
  2500. if chan then close chan;
  2501. if fl eq caar ipl!* then ipl!* := cdr ipl!*
  2502. else errach list("FILE STACK CONFUSION",fl,ipl!*)>>;
  2503. !*echo := echo; %restore echo status;
  2504. if ipl!* and null contl!* then ifl!* := car ipl!*
  2505. else ifl!* := nil;
  2506. if ifl!* then <<rds cadr ifl!*; curline!* := caddr ifl!*>>
  2507. else rds nil
  2508. end;
  2509. symbolic procedure out u;
  2510. %U is a list of one file;
  2511. begin integer n; scalar chan,fl,x;
  2512. n := linelength nil;
  2513. if null u then return nil
  2514. else if car u eq 't then return <<wrs(ofl!* := nil); nil>>;
  2515. fl := mkfil car u;
  2516. if not (x := assoc(fl,opl!*))
  2517. then <<chan := open(fl,'output);
  2518. if chan
  2519. then <<ofl!*:= fl . chan; opl!*:= ofl!* . opl!*>>>>
  2520. else ofl!* := x;
  2521. wrs cdr ofl!*;
  2522. linelength n
  2523. end;
  2524. symbolic procedure shut u;
  2525. %U is a list of names of files to be shut;
  2526. begin scalar fl1;
  2527. for each fl in u do
  2528. <<if fl1 := assoc((fl := mkfil fl),opl!*)
  2529. then <<opl!* := delete(fl1,opl!*);
  2530. if fl1=ofl!* then <<ofl!* := nil; wrs nil>>;
  2531. close cdr fl1>>
  2532. else if not (fl1 := assoc(fl,ipl!*))
  2533. then rederr list(fl,"not open")
  2534. else if fl1 neq ifl!*
  2535. then <<close cadr fl1; ipl!* := delete(fl1,ipl!*)>>
  2536. else rederr list("Cannot shut current input file",car fl1)>>
  2537. end;
  2538. deflist ('((in rlis) (out rlis) (shut rlis)),'stat);
  2539. flag ('(in out shut),'eval);
  2540. flag ('(in out shut),'ignore);
  2541. endmodule;
  2542. module inter; % Functions for interactive support.
  2543. % Author: Anthony C. Hearn.
  2544. % Copyright (c) 1987 The RAND Corporation. All rights reserved.
  2545. fluid '(!*int);
  2546. global '(!$eof!$
  2547. !*echo
  2548. !*lessspace
  2549. cloc!*
  2550. contl!*
  2551. curline!*
  2552. edit!*
  2553. eof!*
  2554. erfg!*
  2555. flg!*
  2556. ifl!*
  2557. ipl!*
  2558. key!*
  2559. ofl!*
  2560. opl!*
  2561. techo!*);
  2562. symbolic procedure pause;
  2563. %Must appear at the top-most level;
  2564. if null !*int then nil
  2565. else if key!* eq 'pause then pause1 nil
  2566. else %typerr('pause,"lower level command");
  2567. pause1 nil; %Allow at lower level for now;
  2568. symbolic procedure pause1 bool;
  2569. begin
  2570. if bool then
  2571. if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?"
  2572. then return <<contl!* := nil;
  2573. if ofl!* then <<lprim list(car ofl!*,'shut);
  2574. close cdr ofl!*;
  2575. opl!* := delete(ofl!*,opl!*);
  2576. ofl!* := nil>>;
  2577. edit1(cloc!*,nil)>>
  2578. else if flg!* then return (edit!* := nil);
  2579. if null ifl!* or yesp "Cont?" then return nil;
  2580. ifl!* := list(car ifl!*,cadr ifl!*,curline!*);
  2581. contl!* := ifl!* . !*echo . contl!*;
  2582. rds (ifl!* := nil);
  2583. !*echo := techo!*
  2584. end;
  2585. symbolic procedure yesp u;
  2586. begin scalar bool,ifl,ofl,x,y,z;
  2587. if ifl!*
  2588. then <<ifl := ifl!* := list(car ifl!*,cadr ifl!*,curline!*);
  2589. rds nil>>;
  2590. if ofl!* then <<ofl:= ofl!*; wrs nil>>;
  2591. if null !*lessspace then terpri();
  2592. if atom u then prin2 u else lpri u;
  2593. prin2t " (Y or N)";
  2594. if null !*lessspace then terpri();
  2595. z := setpchar '!?;
  2596. a: x := read();
  2597. % Assume an end-of-file is the same as "yes".
  2598. if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b;
  2599. if null bool then prin2t "TYPE Y OR N";
  2600. bool := t;
  2601. go to a;
  2602. b: setpchar z;
  2603. if ofl then wrs cdr ofl;
  2604. if ifl then rds cadr ifl;
  2605. cursym!* := '!*semicol!*;
  2606. return y
  2607. end;
  2608. symbolic procedure cont;
  2609. begin scalar fl,techo;
  2610. if ifl!* then return nil %CONT only active from terminal;
  2611. else if null contl!* then rederr "No file open";
  2612. fl := car contl!*;
  2613. techo := cadr contl!*;
  2614. contl!* := cddr contl!*;
  2615. if car fl=caar ipl!* and cadr fl=cadar ipl!*
  2616. then <<ifl!* := fl;
  2617. if fl then <<rds cadr fl; curline!* := caddr fl>>
  2618. else rds nil;
  2619. !*echo := techo>>
  2620. else <<eof!* := 1; lprim list(fl,"not open"); error1()>>
  2621. end;
  2622. deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat);
  2623. flag ('(cont),'ignore);
  2624. endmodule;
  2625. end;