Artifact 2c26d7a998fd5aee16a889eab7ce0893fad120b5e9cfc2340c79ca0f2678324a:
- Executable file
r37/packages/scope/coddec.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 42018) [annotate] [blame] [check-ins using] [more...]
module coddec; % Functions for generating declarations. % ------------------------------------------------------------------- ; % Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ; % Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.; % Author : M.C. van Heerwaarden, W.N. Borst. ; % ------------------------------------------------------------------- ; % ; % ------------------------------------------------------------------- ; % The module CODDEC contains the functions, which have to be used to ; % generate declarations, associated with the optimized version of a ; % set of input expressions when the switch Optdecs is turned on. ; % It can also be used via GENTRAN, when the SCOPE-GENTRAN interface is; % modified, by adding the command TYPEALL Prefixlist; ; % GLOBALS : - ; % INDICATORS: CHKTYPE, ARGTYPE ; % ENTRIES : dettype, typecheck, argnrcheck ; % IMPORTED : Subscriptedvarp, symtabput, sybtabget, symtabrem ; % FROM $gentransrc/util.red ; % CONVERSION: Conversion imposes a partial ordering on types. With ; % respect to this ordering, we can speak of types being ; % greater or less than others. Uncertainty in the type of ; % a certain variable or function is expressed by typing ; % the variable in combination with type-bounds, i.e. a ; % variable for which nothing is certain is typed as ; % '(UNKNOWN ALL). ; % REMARK : Double precision declarations are dealt with in the ; % following way: any kind of a double precision ; % declaration causes the gentran switch DOUBLE to be ; % switched on. As a result, ALL declarations in the ; % output will be of double precision. ; % ------------------------------------------------------------------- ; symbolic$ global '(fortconv!* optlang!*)$ fluid '(!*double)$ switch double; symbolic procedure typeall forms; begin scalar b, declst,nforms; on!-double(forms); declst := symtabget(nil, '!*decs!*); if optlang!* = 'fortran2 then <<while declst and not b do << b := cadar declst = 'complex or cadar declst = 'implicit! complex; declst := cdr declst >>; if b then fortconv!* := '(unknown (integer real complex all) (bool all) (char string all) ) else fortconv!* := '(unknown (integer real all) (bool all) (char string all) ) >>; foreach ass in forms do <<ass := car ass . if complexp(ass) then cireval(cdr ass) else cdr ass; asstype(car ass, cdr ass); nforms:=(car ass . cdr ass) . nforms; >>; apply1('arestore,avarlst); % For bootstrapping. nforms := reverse nforms; finish!-typing nforms; fix!-implicit(); return nforms; end; symbolic procedure on!-double(forms); % ------------------------------------------------------------------- ; % eff : Changes the Gentran symbol table and the DOUBLE switch to ; % use the Gentran double precision facility. ; % Any double precision declaration in the symbol table causes ; % the DOUBLE switch to be switched on. Then, these double ; % precision declarations are replaced by their single precision ; % types. Walks also through the FORMS-list an switches DOUBLE ; % switch on when FORMS contains a bigfloat or gaussian bigfloat ; % number. ; % ------------------------------------------------------------------- ; begin scalar newtype; foreach dec in symtabget(nil, '!*Decs!*) do if newtype := assoc(cadr(dec), '((real!*8 . real) (complex!*16 . complex) (implicit! real!*8 . implicit! real) (implicit! complex!*16 . implicit! complex)) ) then << symtabput(nil, car(dec), list(cdr newtype)); !*double := t >>; on!-double1(forms) end; symbolic procedure on!-double1(forms); if pairp(forms) then if doublep(car forms) then !*double := 't else << on!-double1(car forms); on!-double1(cdr forms) >>; symbolic procedure fix!-implicit; % ------------------------------------------------------------------- ; % eff : Checks every declaration in the symbol table if that ; % declaration matches an implicit declaration in the table. ; % If so, the types are checked and the explicit declaration is ; % removed out of the table ; % ------------------------------------------------------------------- ; begin scalar decl, type; foreach decl in symtabget(nil, '!*decs!*) do if (not isimplicit(cadr decl)) and (type := implicitdec(car decl)) then << if greatertype(type, cdr(decl)) then typerror(8, cdr(decl) . type); symtabrem(nil, car(decl)) >> end; % ------------------------------------------------------------------- ; % MODULE Operations on the Symbol table ; % OPERATIONS : getdec, implicitdec, isimplicit, implicittype ; % ------------------------------------------------------------------- ; symbolic procedure getdec(vname); % ------------------------------------------------------------------- ; % args: vname = name of the variable which declaration is requested ; % ret : the type of the variable as it is explicitly or implicitly ; % stored in the symbol table ; % ------------------------------------------------------------------- ; begin scalar decl; decl := symtabget(nil, vname); if not decl then decl := implicitdec(vname); return decl end; symbolic procedure implicitdec(vname); % ------------------------------------------------------------------- ; % args: vname = name of the implicit declared variable which ; % declaration is requested ; % ret : the type of the variable as it is stored in the symbol table ; % ------------------------------------------------------------------- ; begin scalar decl, decs; decl := nil; decs := symtabget(nil, '!*decs!*); while not decl and decs do << if isimplicit(cadar(decs)) and firstmatch(vname,caar(decs)) then decl := list(vname, implicittype(cadar(decs))); decs := cdr(decs) >>; return decl end; symbolic procedure firstmatch(vname, implicit); % -------------------------------------------------------------------- ; % args: vname = variable name ; % implicit = range of an implicit declaration (for instance x!-z); % ret : 'T iff the variable name matches the range, nil otherwise ; % -------------------------------------------------------------------- ; begin scalar first; first := id2int(car(explode(vname))); return first >= id2int(car(explode(implicit))) and first <= id2int(cadddr(explode(implicit))) end; symbolic procedure isimplicit(type); % ------------------------------------------------------------------- ; % args: type = type of a variable ; % ret : 'T iff the type is an implicit type, nil otherwise ; % ------------------------------------------------------------------- ; begin scalar implicit, result, etype; implicit := explode('IMPLICIT! ); etype := explode(type); result := 't; while result and implicit do << result := car(etype) = car(implicit); implicit := cdr(implicit); etype := cdr(etype) >>; return result end; symbolic procedure implicittype(implicit); % ------------------------------------------------------------------- ; % args: implicit = an implicit type ; % ret : the type of the implicit type ; % ------------------------------------------------------------------- ; intern compress pnth(explode implicit,11); symbolic procedure asstype(lhs, rhs); % ------------------------------------------------------------------- ; % Performs typechecking on the assignment statement lhs-rhs, leading ; % to a lhs-type, which fits in the ordering imposed by the rhs. ; % ------------------------------------------------------------------- ; begin scalar lhstype; lhstype := typecheck(dettype(lhs, 'unknown), dettype(rhs, 'unknown), rhs); if atom lhs then symtabput(nil, lhs, list lhstype) else if subscriptedvarp car lhs then symtabput(nil, car lhs, list lhstype) else symtabput(nil, car lhs, append(list if atom lhstype then list lhstype else lhstype, for each ndx in cdr lhs collect 'n ) ) end; symbolic procedure dettype(xpr, minimumtype); % ------------------------------------------------------------------- ; % args: xpr = some expression ; % minimumtype = minimum type xpr should have. This is set when ; % operators are encountered. ; % eff : Determine type of xpr and typecheck arguments of operators in ; % xpr. ; % ret : Type of xpr. If no type is known, '(UNKNOWN ALL) is returned. ; % ------------------------------------------------------------------- ; % % Fixed to handle a NIL returned from OPCHECK mcd 22/7/89 % begin scalar type, dtype, optype, mtype, mntype, mxtype; return if atom(xpr) then if numberp xpr then if floatp(xpr) then 'real else 'integer else if (type := getdec(xpr)) and (type := cadr type) then if greatertype(minimumtype, mintype type) then if greatertype(minimumtype, maxtype type) then typerror(1, xpr) else << symtabput(nil, xpr, list(type:=returntype list(minimumtype,maxtype type))); type >> else type else << symtabput(nil, xpr, list list(minimumtype,'all)); list(minimumtype, 'all) >> else if memq(car xpr, domainlist!*) then if memq(car xpr, '(!:rd!: !:rn!:)) then 'real else if memq(car xpr, '(!:gi!: !:cr!: !:crn!:)) then 'complex else typerror(5, car xpr) else if subscriptedvarp2 car xpr then << for each ndx in cdr xpr do typecheck('integer, dettype(ndx, 'integer), ndx); % argument minimumtype independent of parameter % minimumtype cadr getdec(car xpr) >> else if smember('argtype, car( (optype := opcheck xpr) or '(nil))) then << mtype:=mntype:=mxtype:= car eval get(car xpr,'argtype); % mxtype now contains the first type of the class in % which the arguments must be for each arg in cdr xpr do << dtype := dettype(arg, mtype); if greatertype(type := maxtype dtype, mxtype) then mxtype := type; if greatertype(type := mintype dtype, mntype) then mntype := type >>; if atom cdr optype then << if cdr optype = 'argtype then returntype list(mntype, mxtype) else cdr optype >> else if greatertype(mxtype, cadr optype) then << if greatertype(mntype, cadr optype) then list(mntype, mxtype) else list(cadr optype, mxtype) >> else cadr optype >> else if optype then << type := car optype; if atom type then type := list type; foreach arg in cdr xpr % Number of args already checked do << mtype := firstinclass car type; typecheck(car type, dettype(arg, mtype), arg); type := cdr type >>; cdr optype >> else << for each arg in cdr xpr do dettype(arg, 'unknown); list(minimumtype, 'all) >> end; symbolic procedure typecheck(lhstype, rhstype, rhs); % ------------------------------------------------------------------- ; % args: lhstype = type as known so far for lhs of ass. stat. ; % rhstype = type as known so far for rhs of ass. stat. ; % rhs = rhs of ass. stat ; % eff : The rules used for typechecking are : ; % ; % Condition: Check: Result: ; % ; % lhs |---| mintype(lhs) > OK mintype(lhs) ; % rhs |---| maxtype(rhs) ; % ; % lhs |---| maxtype(lhs) < ERROR ; % rhs |---| mintype(rhs) ; % ; % lhs ...-| maxtype(lhs) < OK when adjust- intersection ; % rhs ...---| maxtype(rhs) ments possible of lhs & rhs ; % ; % all other cases OK intersection ; % of lhs & rhs ; % ; % ret: The - possibly adjusted type of lhs. ; % ------------------------------------------------------------------- ; begin scalar type; if greatertype(mintype lhstype, maxtype rhstype) then mintype lhstype else << type := typeintersec(lhstype, rhstype); if greatertype(maxtype rhstype, maxtype type) then if not(putmaxtype(rhs, maxtype type)) then typerror(2, lhstype . rhstype) >>; return type end; symbolic procedure typeintersec(type1, type2); % ------------------------------------------------------------------- ; % ret : the intersection of the two types. ; % generates an error when the intersection is empty or when the ; % types are in different typeclasses. ; % ------------------------------------------------------------------- ; begin scalar mint, maxt; mint := if greatertype(mintype type1, mintype type2) then mintype type1 else mintype type2; maxt := if greatertype(maxtype type1, maxtype type2) then maxtype type2 else maxtype type1; if greatertype(mint, maxt) then typerror(2, type1 . type2); return returntype list(mint, maxt) end; symbolic procedure mintype type; % ------------------------------------------------------------------- ; % A type may be a pair (l u) wher l is the minimum type for a variable; % and u is the maximum type. This procedure returns the minimum type. ; % ------------------------------------------------------------------- ; if atom type then type else car type; symbolic procedure maxtype type; % ------------------------------------------------------------------- ; % A type may be a pair (l u) wher l is the minimum type for a variable; % and u is the maximum type. This procedure returns the maximum type.; % ------------------------------------------------------------------- ; if atom type then type else cadr type; symbolic procedure returntype type; % ------------------------------------------------------------------- ; % ret: returns mintype if mintype and maxtype are equal and type ; % otherwise. ; % ------------------------------------------------------------------- ; if mintype type = maxtype type then mintype type else if greatertype(mintype type, maxtype type) then typerror(7, nil) else type; symbolic procedure putmaxtype(xpr, type); % ------------------------------------------------------------------- ; % args: xpr = some expression ; % type = maximum type for variables and for the result type of ; % operators. ; % eff : To generate a correctly typed program,the maximum type for xpr; % should be Type. If the result type of the main operator of Xpr; % is not dependent of its arguments, it is sufficient to check ; % this result type. Otherwise, putmaxtype must be applied to all; % arguments. ; % When xpr is a variable and its maximum type is greater than ; % Type the maximum type is tried to be smallened to Type.If this; % is not possible, an error occurs. ; % ret: T if xpr is of correct type, i.e. smaller than Type ; % NIL if it is not possible to smallen the type of xpr when ; % necessary. ; % note: Perhaps this procedure does not choose consequently between ; % returning an error and returning NIL. ; % ------------------------------------------------------------------- ; % % Fixed to handle a NIL returned from OPCHECK mcd 22/7/89 % begin scalar restype, b; return if null xpr then t else if atom xpr then if numberp xpr then geqtype(type, dettype(xpr, 'integer)) else if restype := cadr getdec(xpr) then if atom restype then geqtype(type, restype) else if geqtype(type, mintype restype) then << if type = mintype restype then symtabput(nil, xpr, list type) else symtabput(nil, xpr, list list(mintype restype, type)); t >> else nil else typerror(3, xpr) else if subscriptedvarp car xpr then geqtype(type, cadr getdec(car xpr)) % No uncertainty allowed in type of matrix else if (restype := cdr (opcheck(xpr) or '(nil))) = 'argtype or listp(restype) then << b := t; for each arg in cdr xpr do b := b and putmaxtype(arg, type); b >> else if restype then geqtype(type, restype) else geqtype(type, 'unknown) end; % ------------------------------------------------------------------- ; % MODULE : CONVERSION fortconv!*, cconv!*, ratconv!*, pasconv!*, ; % f90conv!* ; % STRUCTURE : conv!* ::= (UNKNOWN (class-list)-list) ; % class-list ::= ordered list of types: a type can be ; % converted to the types which occur in the rest of the ; % list. ; % OPERATIONS: greatertype, geqtype, lesstype, getnum ; % GLOBALS : fortconv!*, cconv!*, ratconv!*, pasconv!*,f90conv!* ; % INDICATORS: conversion ; % ------------------------------------------------------------------- ; global '(fortconv!* cconv!* ratconv!* pasconv!* f90conv!* optlang!*); put('fortran, 'conversion, 'fortconv!*); put('f90, 'conversion, 'f90conv!*); put('c, 'conversion, 'cconv!*); put('ratfor, 'conversion, 'ratconv!*); put('pascal, 'conversion, 'pasconv!*); fortconv!* := '(unknown (integer real complex all) (bool all) (char string all) ); f90conv!* := '(unknown (integer real complex all) (bool all) (char string all) ); cconv!* := ratconv!* := pasconv!* := '(unknown (integer real all) (bool all) (char string all) ); symbolic procedure getnum; % ------------------------------------------------------------------- ; % Returns class of numeric types. ; % ------------------------------------------------------------------- ; begin scalar conv, found; conv := eval get(if optlang!* then optlang!* else 'fortran, 'conversion); while not found and (conv := cdr conv) do if caar conv = 'integer then found := t; return car conv end; symbolic procedure greatertype(t1, t2); % ------------------------------------------------------------------- ; % args: t1 = t2 = type ; % ret : T if t1 > t2 ; % t ; % ; % NIL if t1 <= t2 ; % t ; % note: > means greater in the sense of the ordering which is ; % t ; % described above for various languages. ; % ------------------------------------------------------------------- ; begin scalar conv, class, found, found1, found2, f; conv := eval get(if optlang!* then optlang!* else 'fortran, 'conversion); if car conv = t2 then f := t else if car conv = t1 then f := nil else << while (conv := cdr conv) and not found do << class := car conv; while class and not found2 do << if car class = t1 then found1 := t; if car class = t2 then found2 := t else class := cdr class >>; if found2 then << class := cdr class; while class and not f do if car class = t1 then found1 := f := t else class := cdr class; >>; if (found1 and not found2) or (not found1 and found2) then typerror(4, t1 . t2) else if found1 and found2 then found := t >> >>; return f end; symbolic procedure geqtype(t1, t2); % ------------------------------------------------------------------- ; % args: t1 = t2 = type ; % ret : T if t1 >= t2 ; % t ; % ; % NIL if t1 < t2 ; % t ; % Note: See greatertype. ; % ------------------------------------------------------------------- ; begin scalar conv, class, found, found1, found2, f; conv := eval get(if optlang!* then optlang!* else 'fortran, 'conversion); if car conv = t2 then f := t else if car conv = t1 then nil else << while (conv := cdr conv) and not found do << class := car conv; while class and not found2 do << if car class = t1 then found1 := t; if car class = t2 then found2 := t else class := cdr class >>; if found2 then while class and not f do if car class = t1 then found1 := f := t else class := cdr class; if (found1 and not found2) or (not found1 and found2) then typerror(4, t1 . t2) else if found1 and found2 then found := t >> >>; return f end; symbolic procedure lesstype(t1, t2); greatertype(t2, t1); symbolic procedure firstinclass type; % ------------------------------------------------------------------- ; % Return : First (smallest) type of the class of types in which Type ; % belongs. ; % ------------------------------------------------------------------- ; begin scalar conv, found, class, mclass; conv := eval get(if optlang!* then optlang!* else 'fortran, 'conversion); return if (type = 'all) or (type = 'unknown) then 'unknown else << while (conv := cdr conv) and not found do << mclass := car(class := car conv); while class and not found do << if car class = type then found := t; class := cdr class >> >>; if found then mclass else typerror(5, type) >> end; symbolic procedure lastinclass type; % ------------------------------------------------------------------- ; % Returns : Last (greatest) type of the class of types in which Type ; % belongs. ; % ------------------------------------------------------------------- ; begin scalar conv, found, class; conv := eval get(if optlang!* then optlang!* else 'fortran, 'conversion); if type neq 'all then while (conv := cdr conv) and not found do << class := car conv; while class and not found do if car class = type then << found := t; repeat type := car class until (class := cdr class) = '(all) >> else class := cdr class >>; return type end; % ------------------------------------------------------------------- ; % MODULE : FUNCTION TYPING ; % STRUCTURE : ; % OPERATIONS: resulttype ; % GLOBALS : ; % INDICATORS: type: (argumenttype . resulttype) ; % argumenttype: ; % Atom ==> 1 argument ; % List with 1 type ==> number of arguments must be >= 2 ; % List with > 1 type ==> number of types = number ; % of arguments; % resulttype has the following meaning ; % ; % resulttype meaning ; % ; % 'argtype the type of the result is determined by the arguments ; % 'type the type of the result is always the given type ; % '(type) the type of the result is determined in the following ; % way: ; % ; % maximium of the minimum of the ; % mintypes of the maxtypes of the ; % arguments arguments ; % ; % type |------------------| ; % |------------------| = type of the result ; % ; % |-----type---------| ; % type---------| = type of the result ; % ; % |------------------| type ; % type = type of the result ; % ; % argtype: ; % The type of a function or argument can be one of a ; % class of types. Evaluation of the value of this ; % indicator returns the whole class. ; % ; % ------------------------------------------------------------------- ; for each op in '(times plus difference) do << put(op, 'chktype, '((argtype) . argtype)); put(op, 'argtype, '(getnum)) >>; put('quotient, 'chktype, '((argtype argtype) . (real))); put('quotient, 'argtype, '(getnum)); put('expt, 'chktype, '((argtype argtype) . argtype)); put('expt, 'argtype, '(getnum)); put('minus, 'chktype, '(argtype . argtype)); put('minus, 'argtype, '(getnum)); for each op in '(or and) do put(op, 'chktype, '((bool) . bool)); put('not, 'chktype, '(bool . bool)); for each op in '(eq leq geq greaterp lessp neq) do << put(op, 'chktype, '((argtype argtype) . bool)); put(op, 'argtype, '(getnum)) >>; for each op in '(sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh cot log sqrt) do put(op, 'chktype, '(real . real)); symbolic procedure opcheck op; % ------------------------------------------------------------------- ; % args: op = operator ; % eff : performs a check on the number of arguments ; % ret : Complete type of operator, i.e. ; % (type-of-arguments-list . resulttype) ; % note: Decisions about what to do when Op's type is ARGTYPE are left ; % to the calling procedures. ; % ------------------------------------------------------------------- ; begin scalar optype; return if not(optype := get(car op, 'chktype)) then 'nil else if atom car optype then if length cdr op = 1 then optype else typerror(6, car op) else if cdar optype then if length cdr op = length car optype then optype else typerror(6, car op) else if length cdr op >= 2 then optype else typerror(6, car op) end; % ------------------------------------------------------------------- ; % MODULE finish type analysis & checking. ; % Each variable will be bound to a single type. ; % ------------------------------------------------------------------- ; symbolic procedure finish!-typing prflst; % ------------------------------------------------------------------- ; % args: prflst = the prefixlist from the optimizer. ; % eff : After some simple checks, each variable in the assignment has ; % a definite type. This type can be found in the symbol table. ; % ret : - ; % ------------------------------------------------------------------- ; begin scalar ltype, rtype; for each item in prflst do if (ltype := det!&bind(car item, 'all)) then << if ltype = 'all then if (rtype := det!&bind(cdr item, ltype)) = 'all then write list("Unknown type for operator", cdr item) else ltype := lastinclass rtype else rtype := det!&bind(cdr item, ltype); if greatertype(rtype, ltype) then typerror(2, item) else if atom car item then symtabput(nil, car item, list ltype) else symtabput(nil, caar item, list ltype) >> else % When a lhs variable is not declared, it is a variable % generated by the optimizer which still needs typing. symtabput(nil, car item, list det!&bind(cdr item, 'all)) end; symbolic procedure det!&bind(xpr, maximumtype); % ------------------------------------------------------------------- ; % args: xpr = expression for which a definite type must be determined ; % maximumtype = the maximum type which Xpr may obtain; only used; % in cases where the variable's type is ; % (UNKNOWN ALL). ; % Typechecking is done in finish!-typing. ; % eff : if xpr is a variable,its definite type is stored on the symbol; % table. ; % ret : the type of Xpr after binding all variables to a certain type.; % ------------------------------------------------------------------- ; % % Fixed to handle a NIL returned from OPCHECK mcd 22/7/89 % begin scalar type, mtype, optype; return if idp(xpr) or constp(xpr) then if constp(xpr) then dettype(xpr, 'integer) else det!&bindmax(xpr, maximumtype) else if subscriptedvarp car xpr then << for each ndx in cdr xpr do det!&bind(ndx, 'integer); det!&bindmax(car xpr, maximumtype) >> else if smember('argtype, car((optype := opcheck xpr) or '(nil))) then << mtype := 'unknown; for each arg in cdr xpr do if greatertype(type:= det!&bind(arg,maximumtype),mtype) then mtype := type; % Fixed to handle complex division. ; if atom cdr optype then << if cdr optype = 'argtype then mtype else cdr optype >> else if greatertype(mtype, cadr optype) then mtype else cadr optype >> else if optype then << type := car optype; if atom type then type := list type; for each arg in cdr xpr do << det!&bind(arg, car type); type := cdr type >>; cdr optype >> else << for each arg in cdr xpr do det!&bind(arg, 'all); maximumtype >> end; symbolic procedure det!&bindmax(xpr, maximumtype); begin scalar type; if pairp(type := cadr getdec(xpr)) then if maxtype type = 'all then if mintype type = 'unknown then << type := maximumtype; symtabput(nil, xpr, list maximumtype) >> else << type := lastinclass mintype type; if greatertype(type, maximumtype) then type:=maximumtype; symtabput(nil, xpr, list type) >> else symtabput(nil, xpr, list(type := maxtype type)); return type end; symbolic procedure typerror(errornr, xpr); % ------------------------------------------------------------------- ; % eff : Besides the error message, the declarations known so far are ; % printed. ; % ------------------------------------------------------------------- ; if errornr = 6 then rederr list("Wrong number of arguments for", xpr) else << terpri!* t; write("***** Type error:"); terpri!* t; printdecs(); if errornr = 1 then rederr list("Wrong type for variable", xpr) else if errornr = 2 then <<assgnpri(cdr xpr, list car xpr, t); rederr list("Wrong typing")>> else if errornr = 3 then rederr list(xpr, "not checked on type") else if errornr = 4 then rederr list(car xpr, "and", cdr xpr, "in different type classes") else if errornr = 5 then rederr list(xpr, "is an unknown type") else if errornr = 7 then rederr list("Wrong reasoning") else if errornr = 8 then rederr list(car xpr, "cannot be redeclared to",cdr xpr) else rederr list("Unknown type error") >>; symbolic expr procedure subscriptedvarp v; % --------------------------------------------------------------- ; % Returns t if and only if v has been declared to be a ; % subscripted variable name, or assumed to be so by the parser. ; % --------------------------------------------------------------- ; length symtabget(nil, v) > 2 or flagp(v,'subscripted); symbolic expr procedure subscriptedvarp2 v; % --------------------------------------------------------------- ; % Returns t if and only if v has been declared to be a ; % subscripted variable name. ; % --------------------------------------------------------------- ; length symtabget(nil, v) > 2; global '(!*symboltable!*); symbolic expr procedure dumpsymtab; begin scalar res; res := foreach pn in !*symboltable!* conc list( list('symtabput,mkquote pn, mkquote '!*type!*, mkquote symtabget(pn, '!*type!*)), list('symtabput,mkquote pn, mkquote '!*params!*, mkquote symtabget(pn,'!*params!*)), list('symtabput,mkquote pn, mkquote '!*decs!*, mkquote symtabget(pn, '!*decs!*)) ); res := 'progn . list('setq,'!*symboltable!*,mkquote !*symboltable!*) . res; return res end; %--- Coddec patch. John Boers wil i.p.v. ranges ook atomen impliciet %--- declareren. dus: s,t i.p.v. s-t. symbolic procedure firstmatch(vname, implicit); % -------------------------------------------------------------------- ; % args: vname = variable name ; % implicit = range of an implicit declaration (for instance x!-z); % ret : 'T iff the variable name matches the range, nil otherwise ; % -------------------------------------------------------------------- ; begin scalar first; first := id2int(car(explode(vname))); if freeof(explode implicit,'!-) then return first=id2int(car(explode(implicit))) else return first >= id2int(car(explode(implicit))) and first <= id2int(cadddr(explode(implicit))) end; endmodule; end;