1module proc; % Procedure statement. 2 3% Author: Anthony C. Hearn. 4 5% Copyright (c) 1991 RAND. All rights reserved. 6 7% Redistribution and use in source and binary forms, with or without 8% modification, are permitted provided that the following conditions are met: 9% 10% * Redistributions of source code must retain the relevant copyright 11% notice, this list of conditions and the following disclaimer. 12% * Redistributions in binary form must reproduce the above copyright 13% notice, this list of conditions and the following disclaimer in the 14% documentation and/or other materials provided with the distribution. 15% 16% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 18% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 19% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 20% CONTRIBUTORS 21% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 22% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 23% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 24% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 25% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 26% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 27% POSSIBILITY OF SUCH DAMAGE. 28% 29 30 31fluid '(!*argnochk !*noinlines !*loginlines !*redeflg!* fname!* ftype!* 32 !*strict_argcount !*comp ifl!* curline!*); 33 34% !*loginlines will cause a compile-time report of patterns of inline usage. 35!*loginlines := t; 36 37global '(!*lose !*micro!-version cursym!* curescaped!* erfg!* 38 ftypes!*); 39 40fluid '(!*defn new_inline_definitions); 41 42new_inline_definitions := nil; 43 44!*lose := t; 45 46ftypes!* := '(expr fexpr macro); 47 48% If foo(a,b) is already a defined function than when you go 49% symbolic emb procedure foo(u,v); 50% <new body ... foo(u', v') ... >; 51% the function is redefined, but the inner call within it refers to the 52% existing definition. So this can wrap new stuff around an existing 53% procedure body. It is ONLY intended for debugging and I suggest that 54% functions that have been embedded should not be written out in 55% fasl files or saved on heap images (for instance it is not always going 56% to be certain that the proper identity of the gensym used here will 57% survive serialization). This may however be useful for debugging as 58% a more flexible alternative to use of "tr foo;". In reduce4 mode this was 59% wired into the parser, aned there is a commented out autoload directive 60% for the "embfn" function in PSL, so I avoided clashing with that name 61% here. 62 63put('emb, 'procfn, 'portable!-embfn); 64 65symbolic procedure portable!-embfn(name, args, body); 66 begin 67 scalar g; 68 if not eqcar(getd name, 'expr) then 69 rederr "Trying to embed around undefined function, or a fexpr or macro"; 70 g := gensym(); 71 return list('progn, 72 list('copyd, mkquote g, mkquote name), 73 list('de, name, args, ssubst(g, name, body))) 74% I replace name by the gensym except within quotes. This will have 75% untoward effects if name is also the the name of a fluid variable... 76% but since this is JUST for debugging I will ignore that issue just 77% for now. Another case where this scheme will fail is if there is a 78% use of (eg) apply('name, ...) or an errorset that wants to call the 79% function and so creates a structure with its name in it. So you 80% see that overall this is a marginal and dodgy bit of code - but it can 81% still be really useful when used in SIMPLE ways. 82 end; 83 84symbolic procedure mkprogn(u,v); 85 if eqcar(v,'progn) then 'progn . u . cdr v else list('progn,u,v); 86 87symbolic procedure proc!-add!-info(name,info,body); 88 if null info then body 89 else proc!-add!-info(name, 90 cdr info, 91 mkprogn(list('put,mkquote name,mkquote caar info,mkquote cdar info),body)); 92 93symbolic procedure formproc(u,vars,mode); 94 begin scalar obody,body,fname!*,name,type,varlis,x,y,fl,n,info; 95 u := cdr u; 96 name := fname!* := car u; 97 if cadr u then mode := cadr u; % overwrite previous mode 98 u := cddr u; 99 type := ftype!* := car u; 100 if flagp(name,'lose) and (!*lose or null !*defn) 101 then return << lprim list(name, 102 "not defined (LOSE flag)"); 103 '(quote nil) >> 104 else if !*redeflg!* and getd name 105 then lprim list(name,"redefined"); 106 varlis := cadr u; 107 while varlis do << 108 if null car varlis or car varlis = 't then rsverr car varlis; 109 varlis := cdr varlis >>; 110 varlis := cadr u; 111% For the benefit of CSL - and also perhaps for source analysis tools - if 112% a fluid variable is bound I will insert a (DECLARE...) form at the 113% head of the function. The justification for this is that the status of 114% the variable as fluid is being checked at parse time. With CSL I capture 115% the Lisp versions of function definitions and translate them into C++ 116% at a later stage, and when I do that the fluid declarations are in general 117% not still around. But with the adjustment that is made here I have a local 118% fluid declaration to guide me. I test for DECLARE being defined (it should 119% be a special form not a regular function) rather than looking at the 120% identity of the Lisp system. 121#if (getd 'declare) 122 while varlis do << 123 if fluidp car varlis or globalp car varlis then 124 fl := car varlis . fl; 125 varlis := cdr varlis >>; 126 varlis := cadr u; 127#endif 128 body := caddr u; 129 if pairp cdddr u then info := cadddr u; 130 x := if eqcar(body,'rblock) then cadr body else nil; 131 y := pairxvars(varlis,x,vars,mode); 132 if x then body := car body . rplaca!*(cdr body,cdr y); 133% body:= form1(body,car y,mode); % FORMC here would add REVAL. 134 body := if flagp(name,'formc) then formc(body,car y,mode) 135 else form1(body,car y,mode); 136% !*noinlines being set causes every inline that is defined to be downgraded 137% to a regular procedure. 138 if !*noinlines and type = 'inline then type := 'expr; 139#if (getd 'declare) 140% Note the non-Common way in which the DECLARE sits within a PROGN here. 141% Furthermore I only insert DECLARE for sort-of ordinary functions. 142% Specifically this will not include "inline procedure"... but a consequence 143% of this will be that it will be a mistake to introduce an inline function 144% that attempts to bind a fluid... because the variable concerned might not be 145% declared fluid at the point where the inline definition is used. 146 if fl and type memq '(expr fexpr macro) then 147 body:=list('progn, 148 list('declare, 'special . fl), 149 body); 150#endif 151 obody:=body; 152 if type = 'inline then begin 153 scalar dd; 154 dd := list('lambda,varlis,body); 155 if not (dd = get(name, 'inline)) then << 156 if not zerop posn() then terpri(); 157 prin2 "+++ Record new inline definition:"; 158 terpri(); 159% I had been minded to use prettyprint here, however with PSL the file that 160% contains the code for prettyprint sets up some inline definitions and it 161% appears that an attempt to use prettyprint will fail there. What is worse 162% is that I tried "if getd 'prettyprint then prettyprint else print" but that 163% also crashed when PSL tried to build the prettyprint module. 164 print list('de,name,varlis,body); 165 new_inline_definitions := (name . dd) . new_inline_definitions >> 166 end; 167 if (not(type = 'inline) and get(name,'inline)) or 168 (not(type = 'smacro) and get(name,'smacro)) 169 then lprim list("SMACRO/INLINE",name,"redefined"); 170% the next line generates warnings if any arguments are not used (in symbolic 171% mode, and not counting arguments that are fluid). 172 symbvarlst(varlis,body,mode); 173 if type = 'expr then body := list('de,name,varlis,body) 174 else if type = 'fexpr then body := list('df,name,varlis,body) 175 else if type = 'macro then body := list('dm,name,varlis,body) 176 else if (x := get(type,'procfn)) 177 then return apply3(x,name,varlis,body) 178 else << body := list('putc, 179 mkquote name, 180 mkquote type, 181 mkquote list('lambda,varlis,body)); 182 if !*defn then lispeval body >>; 183 body := proc!-add!-info(name,info,body); 184 if not(mode = 'symbolic) 185 then body := 186 mkprogn(list('flag,mkquote list name,mkquote 'opfn),body); 187 if !*argnochk and type memq '(expr inline smacro) 188 then << 189 if (n:=get(name, 'number!-of!-args)) and 190 not flagp(name, 'variadic) and 191 n neq length varlis then << 192 if !*strict_argcount then 193 lprie list ("Definition of", name, 194 "different count from args previously called with") 195 else lprim list(name, "defined with", length varlis, 196 "but previously called with",n,"arguments") >>; 197 body := mkprogn(list('put,mkquote name, 198 mkquote 'number!-of!-args, 199 length varlis), 200 body) >>; 201 if !*defn and type memq '(fexpr macro inline smacro) 202 then lispeval body; 203% "inline" procedures define a regular procedure as well as saving the 204% definition so it can be expanded in place elsewhere. 205 if type = 'inline then 206 body := print mkprogn(list('de,name,varlis,obody), body); 207 return if !*micro!-version and type memq '(fexpr macro smacro) 208 then nil 209 else body 210 end; 211 212put('procedure,'formfn,'formproc); 213 214symbolic procedure formde(u, vars, mode); 215 if mode = 'symbolic then 216 formproc( 217 list('procedure, cadr u, 'symbolic, 'expr, caddr u, 218 if null cddddr u then cadddr u else 'progn . cdddr u), 219 vars, 220 mode) 221 else ('list . algid(car u,vars) . formlis(cdr u, vars,mode)); 222 223put('de,'formfn,'formde); 224 225symbolic procedure pairxvars(u,v,vars,mode); 226 %Pairs procedure variables and their modes, taking into account 227 %the convention which allows a top level prog to change the mode 228 %of such a variable; 229 begin scalar x,y; 230 while u do << 231 if (y := atsoc(car u,v)) then << 232 v := delete(y,v); 233 if not(cdr y = 'scalar) then x := (car u . cdr y) . x 234 else x := (car u . mode) . x >> 235 else if null idp car u or get(car u,'infix) or get(car u,'stat) then 236 symerr(list("Invalid parameter:",car u),nil) 237 else x := (car u . mode) . x; 238 u := cdr u >>; 239 return append(reversip!* x,vars) . v 240 end; 241 242symbolic procedure starts!-with(a, b); 243 if null b then t 244 else if null a then nil 245 else if eqcar(a, car b) or 246 (eqcar(a,'!\) and eqcar(b, '!/)) then starts!-with(cdr a, cdr b) 247 else nil; 248 249symbolic procedure simplify!-filename s; 250 begin 251 scalar a, b; 252% The issue that I am concerned with here is that the full version of 253% a file-name may be very long, and including all of it in messages can be 254% unhelpful. To cope with files-names that are within the Reduce source 255% tree I will apply what is perhaps a hack, and I will remove any initial 256% part of a path that ends in "/packages/". Thus (for instance) one of the 257% more basic test files will end up just names as "alg/alg.tst" rather than 258% anything longer. 259 a := explode2 s; 260 b := explode2 "/packages/"; 261 while a and not starts!-with(a, b) do a := cdr a; 262 if null a then return s; 263 a := cddddr cddddr cddr a; 264 return list2string a; 265 end; 266 267!#if (or (null (getd 'mkhash)) (flagp 'mkhash 'rlisp)) 268 269% I need to simulate hash tables, which PSL does not appear to provide. 270% Well I will provide a minimal functional (but not performance) 271% replacement here for use in any Lisp that does not heva a function 272% called "mkhash" defined. 273 274% The type is 0 for EQ hashes and all other cases are treated as EQUAL 275% ones here. Since I am simulating "hash" tables in PSL using just simple 276% association lists I do not have any use for a concept of initial size or 277% the factor by which tables expand once they become full. 278 279% I think a nicer implementation would be to use genuine hashed tables with 280% PSL providing a function that hashed items. For EQ hashing that could be 281% based on the machine representation of the (reference to) an item, while 282% for equal it could traverse lists but use the address for symbols. The key 283% issue there is that garbage collection moves things around! The neatest idea 284% I have about that is to have each hash table record in its header the 285% sequence number of garbage collection with respect to which it is valid. 286% puthash and gethash would then check that on entry and perform a rehash 287% operation if out of date. If one can be confident that garbage collection 288% will not be triggered while performing gethash, and if puthash and rehash 289% record the garbage collection number when they start and check if items are 290% already present first using gethash (and if rehash re0runs itself if it 291% finds that a GC happened while it was active). I think all is not too 292% messy. But because hash tables are not very heavily used this is not a high 293% priority! 294 295symbolic procedure mkhash(size, type, expansion); 296 type . nil; 297 298symbolic procedure clrhash u; 299 rplacd(u, nil); 300 301symbolic procedure gethash(key, table); 302 begin 303% Of course use of assoc/atsoc here is not good for performance if you 304% end up with many items stored... 305 table := (if car table = 0 then atsoc(key, cdr table) 306 else assoc(key, cdr table)); 307 if null table then return nil 308 else return cdr table 309 end; 310 311symbolic procedure puthash(key, table, val); 312 begin 313 scalar w; 314 w := (if car table = 0 then atsoc(key, cdr table) 315 else assoc(key, cdr table)); 316 if w then << 317 rplacd(w, val); 318 return val >>; 319 rplacd(table, (key . val) . cdr table); 320 return val 321 end; 322 323symbolic procedure hashcontents table; 324 cdr table; 325 326flag('(mkhash), 'rlisp); 327 328!#endif 329 330% At present this code only allows single token type specifiers. This is 331% far from enough, but may still do as a placeholder while I implement 332% more of the infrastructure. 333 334% read_type() reads a description of a type. 335 336symbolic procedure read_type(); 337 begin 338 scalar x; 339 x := cursym!*; 340 scan(); 341 return x; 342 end; 343 344% read_typed_name will read either "name" or "name : type", and if the 345% explicit type is not given it defaults to "general". 346 347symbolic procedure read_typed_name(); 348 begin 349 scalar a; 350 a := cursym!*; 351 scan(); 352 if not (cursym!* = '!*colon!*) then return (a . 'general); 353 scan(); 354 return (a . read_type()) 355 end; 356 357% read_namelist knows that there is at least one name - so it reads 358% a sequence of typed names connected to "," tokens. It stops as soon 359% as the tyken following a typed name is not a comma. 360 361symbolic procedure read_namelist(); 362 begin 363 scalar a; 364 if not valid_as_variable cursym!* then return nil; 365 a := read_typed_name(); 366 if not (cursym!* = '!*comma!*) then return list a; 367 scan(); 368 return a . read_namelist() 369 end; 370 371% valid_as_variable is a function that exists because the Rlisp tokenization 372% code does not make a clear distinction between reserved words and ordinary 373% identifiers. 374 375symbolic procedure valid_as_variable u; 376 idp u and 377 not flagp(u, 'invalid_as_variable); 378 379flag('(nil t !*comma!* !*lpar!* !*rpar!* !*colon!* !*semicol!*), 380 'invalid_as_variable); 381 382% read_signature is used for procedure headers. The syntax it accepts 383% should be as shown here (where the final ";" tells parsing when to stop). 384% name ; No arguments, no type info 385% name : type ; No arguments, resuly type specified 386% name arg ; A single argument 387% name arg1 : type1 ; One arg with arg type specified 388% name arg1 : type1 : type ; Both arg and result type specified 389% name() ; No arguments, but () to stress that! 390% name() : type ; 391% name( arg1, ...) ; Argument or arguments without types 392% name( arg1, ...) : type ; Ditto but with result type 393% name( arg1:type1, ...) ; Arguments may have type specifiers 394% name( arg1:type1, ...) : type ; 395% Note that "name arg:type;" is treated as "name(arg:type);" rather 396% then "name(arg):type;". 397% 398% For compatibility I also need 399% arg1[:type1] infix-operator arg1[:type2] [:result_type] 400% and this is used in a situation 401% infix .*; inline procedure u .* v; u + v; 402% where I can even imagine wanting to put in type decorations. Oh bother - 403% I had thought I could get away with not supporting that case! 404 405 406symbolic procedure read_signature(); 407 begin 408 scalar x, y; 409 x := cursym!*; 410 if not valid_as_variable x then 411 rerror('rlisp, 7, list(x, "invalid as formal parameter name")); 412 scan(); 413 if cursym!* = '!*semicol!* then return list(list x, 'general); 414 if cursym!* = '!*colon!* then << 415% The signature started off as "x : type". There are two wanys this 416% can end up. One is just as 417% x : type ; 418% which introduces a procedure with no arguments but with a declared 419% return type. The other is 420% x : type infix_op y [: type] [: type] ; 421% where the procedure is specified using infix notation but with a type 422% for at least its left operand. 423 scan(); 424 y := read_type(); 425 if cursym!* = '!*semicol!* then return list(list x, y) 426 else if not idp cursym!* or 427 not get(cursym!*, 'infix) then symerr(nil, cursym!*); 428 x := x . y; 429 y := cursym!*; 430 scan(); 431 x := list(y, x, read_typed_name()) >> 432 else if cursym!* = '!*lpar!* then << 433 scan(); 434 if cursym!* = '!*rpar!* then x := list x 435 else << 436 x := x . read_namelist(); 437 if not (cursym!* = '!*rpar!*) then rerror('rlisp, 8, 438 list(cursym!*, "found where right parenthesis expected")) >>; 439 scan() >> 440 else if idp cursym!* and get(cursym!*, 'infix) then << 441% This is the case 442% u infix_op v [: type] [: type] 443 y := cursym!*; 444 scan(); 445 x := list(y, x . 'general, read_typed_name()) >> 446 else x := list(x, read_typed_name()); 447 if cursym!* = '!*colon!* then << 448 scan(); 449 return list(x, read_type()) >> 450 else return list(x, 'general) 451 end; 452 453symbolic procedure make_tuple_type x; 454 if null x then 'unit 455 else if null cdr x then cdar x 456 else 'times . collect_cdrs x; 457 458% At this stage in the bootstrap process I can not use a "for each" 459% statement, so I write this out as a separate function 460 461symbolic procedure collect_cars u; 462 if null u then nil 463 else caar u . collect_cars cdr u; 464 465symbolic procedure collect_cdrs u; 466 if null u then nil 467 else cdar u . collect_cdrs cdr u; 468 469symbolic procedure procstat1 mode; 470 begin scalar bool, u, type, x, y, z, file, line, info; 471% Note the file and line that this procedure is in. This will be the 472% location that the procedure statement starts on. 473% I can tag it with the file name and line where it was defined, and that 474% may be really helpful in some debugging context. 475 if ifl!* then << file := car ifl!*; 476% By using intern I turn the string that is the file-name into a symbol. 477% That arranges that when the file-name is used multiple times only one 478% copy is kept in memory. 479 info := list('defined!-in!-file . intern simplify!-filename file, 'defined!-on!-line . line) >> 480 else file = "-"; 481% I think that erfg!* will be set if we have already suffered an error, so 482% we may be parsing in a sort of recovery mode. 483 bool := erfg!*; 484% fname!* is set to the name of a procedure while we are parsing the body 485% of that procedure, so if it is set here then we have an illegal attempt at 486% a procedure definition nested within another. This will most typically 487% occur if a previous procedure fails to have enough ">>" or "end" tokens. 488 if fname!* then << 489 bool := t; 490 errorset!*('(symerr (quote procedure) t),nil) >> 491 else << 492% Here we allow for "procedure", "symbolic procedure", "algebraic procedure" 493% or "maud procedure" with (in that case) "maud" ending up in the variable 494% "type". If the word "procedure" is not found we will complain. 495 if cursym!* = 'procedure then type := 'expr 496 else << type := cursym!*; scan() >>; 497 if not(cursym!* = 'procedure) then << 498 errorset!*('(symerr (quote procedure) t),nil) >> 499 else << 500% Reduce 4 differs from previous versions... it allows type specifiers. 501 if !*reduce4 then << 502% Name of the procedure comes next 503 fname!* := scan(); 504 if not idp fname!* then typerr(fname!*,"procedure name") 505 else << 506 scan(); 507% Move past the procedure name and read the list of parameters. 508 y := errorset!*(list('read_param_list,mkquote mode),nil); 509 if not errorp y then << 510% If parameters were read happily and the next token is a colon then there 511% will be a type given after it. 512 y := car y; 513 if cursym!* = '!*colon!* then mode := read_type() >> >> >> 514 else << 515 scan(); 516 x := read_signature(); 517% The result of read_signature is 518% ((fname (arg1 . type1) ...) result_type) 519% I will edit that to make something that looks a bit more like the style 520% of type signature I have used before... Examples could be 521% (arrow unit general) 522% (arrow integer integer) 523% (arrow (times general integer general) general) 524% where "unit" denotes nothing (ie not having any arguments), "general" is 525% where the type had not been specified, and otherwise at present types 526% are merely symbols. 527 info := ('procedure_type . 'arrow . make_tuple_type cdar x . cdr x) . info; 528 x := car x; 529 fname!* := car x; 530 x := fname!* . collect_cars cdr x; 531 y := cdr x >> >> >>; 532% Recover a bit of there was an end of file encountered while reading the 533% procedure heading. 534 if eof!*>0 then << 535 cursym!* := '!*semicol!*; 536 curescaped!* := nil >> 537 else << 538% Now read the procedure body. It is quite reasonable to use xread here. 539 z := errorset!*('(xread t),nil); 540 if not errorp z then z := car z; 541 if null erfg!* then 542 z := list('procedure, 543 if null !*reduce4 then car x else fname!*, 544 mode,type,y,z,info) >>; 545% Parsing is complete. So now just tidy up. 546 remflag(list fname!*,'fnc); 547 fname!* := nil; 548 if erfg!* then << 549 z := nil; 550% What seems to be going on here is that most errors spotted during parsing 551% get deferred to here. I rather believe that this is so that the state of 552% Reduce is not messed up too much by a parse failure, and so that lines 553% of input beyond an error get skipped past in a reasonable way. 554 if not bool then error1() >>; 555% In sensible cases the value of z here will be something like 556% (de maud (arg1 ... argn) body) 557 return z 558 end; 559 560symbolic procedure procstat; 561 procstat1 nil; 562 563deflist ('((procedure procstat) (expr procstat) (fexpr procstat) 564 (emb procstat) (macro procstat) (inline procstat) 565 (smacro procstat)), 566 'stat); 567 568% Next line refers to bootstrapping process. 569 570if get('symbolic,'stat) = 'procstat then remprop('symbolic,'stat); 571 572deflist('((lisp symbolic)),'newnam); 573 574endmodule; 575 576end; 577