diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 20 | ||||
| -rw-r--r-- | src/interp/define.boot | 6 | ||||
| -rw-r--r-- | src/interp/functor.boot | 20 |
3 files changed, 16 insertions, 30 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 72baf917..6cf3cc84 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1138,9 +1138,9 @@ compHasFormat (pred is ["has",olda,b]) == b is ["ATTRIBUTE",c] => ["HasAttribute",a,["QUOTE",c]] b is ["SIGNATURE",op,sig] => ["HasSignature",a, - mkList [MKQ op,mkList [mkDomainConstructor type for type in sig]]] - isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b] - ["HasCategory",a,mkDomainConstructor b] + mkList [MKQ op,mkList [mkTypeForm type for type in sig]]] + isCategoryForm(b,$e) => ["HasCategory",a,mkTypeForm b] + stackAndThrow('"Second argument to %1b must be a category, or a signature or an attribute",["has"]) --% IF @@ -1215,12 +1215,6 @@ compPredicate(p,E) == [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] getSuccessEnvironment(a,e) == - - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e a is ["is",id,m] => IDENTP id and isDomainForm(m,$EmptyEnvironment) => e:=put(id,"specialCase",m,e) @@ -1234,14 +1228,6 @@ getSuccessEnvironment(a,e) == e getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E a is ["case",x,m] and IDENTP x => --the next two lines are necessary to get 3-branched Unions to work -- old-style unions, that is diff --git a/src/interp/define.boot b/src/interp/define.boot index e3dc8934..a4c31697 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -870,7 +870,7 @@ genDomainView(viewName,originalName,c,viewSelector) == c is ['SubsetCategory,c',.] => c' c $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) - cd:= ["%LET",viewName,[viewSelector,originalName,mkDomainConstructor code]] + cd:= ["%LET",viewName,[viewSelector,originalName,mkTypeForm code]] if null member(cd,$getDomainCode) then $getDomainCode:= [cd,:$getDomainCode] viewName @@ -881,7 +881,7 @@ genDomainOps(viewName,dom,cat) == oplist:= substNames(dom,viewName,dom,oplist) cd:= ["%LET",viewName,['mkOpVec,dom,['LIST,: - [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]] + [['LIST,MKQ op,['LIST,:[mkTypeForm mode for mode in sig]]] for [op,sig] in siglist]]]] $getDomainCode:= [cd,:$getDomainCode] for [opsig,cond,:.] in oplist for i in 0.. repeat @@ -1417,7 +1417,7 @@ uncons x == bootStrapError(functorForm,sourceFile) == ['COND, _ ['$bootStrapMode, _ - ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]], + ['VECTOR,mkTypeForm functorForm,nil,nil,nil,nil,nil]], [''T, ['systemError,['LIST,''%b,MKQ CAR functorForm,''%d,'"from", _ ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]] diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 5d2409f5..f2cab9ca 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -311,10 +311,10 @@ cons5(p,l) == setVector0(catNames,definition) == --returns code to set element 0 of the vector --to the definition of the category - definition:= mkDomainConstructor definition + definition:= mkTypeForm definition -- If we call addMutableArg this early, then recurise calls to this domain -- (e.g. while testing predicates) will generate new domains => trouble ---definition:= addMutableArg mkDomainConstructor definition +--definition:= addMutableArg mkTypeForm definition for u in catNames repeat definition:= ["setShellEntry",u,0,definition] definition @@ -387,7 +387,7 @@ setVector3(name,instantiator) == --element 3 is data structure representing category --returns a single LISP statement instantiator is ['DomainSubstitutionMacro,.,body] => setVector3(name,body) - ["setShellEntry",name,3,mkDomainConstructor instantiator] + ["setShellEntry",name,3,mkTypeForm instantiator] mkDomainFormer x == if x is ['DomainSubstitutionMacro,parms,body] then @@ -398,23 +398,23 @@ mkDomainFormer x == x is ['Join,:.] => ['eval,['QUOTE,x]] x -mkDomainConstructor x == +mkTypeForm x == atom x => mkDevaluate x x is ['Join] => nil x is ['LIST] => nil x is ['CATEGORY,:.] => MKQ x x is ['mkCategory,:.] => MKQ x x is ['_:,selector,dom] => - ['LIST,MKQ '_:,MKQ selector,mkDomainConstructor dom] + ['LIST,MKQ '_:,MKQ selector,mkTypeForm dom] x is ['Record,:argl] => - ['LIST,MKQ 'Record,:[mkDomainConstructor y for y in argl]] + ['LIST,MKQ 'Record,:[mkTypeForm y for y in argl]] x is ['Join,:argl] => - ['LIST,MKQ 'Join,:[mkDomainConstructor y for y in argl]] + ['LIST,MKQ 'Join,:[mkTypeForm y for y in argl]] x is ['call,:argl] => ['MKQ, optCall x] --The previous line added JHD/BMT 20/3/84 --Necessary for proper compilation of DPOLY SPAD x is [op] => MKQ x - x is [op,:argl] => ['LIST,MKQ op,:[mkDomainConstructor a for a in argl]] + x is [op,:argl] => ['LIST,MKQ op,:[mkTypeForm a for a in argl]] setVector4(catNames,catsig,conditions) == if $HackSlot4 then @@ -437,7 +437,7 @@ setVector4Onecat(name,instantiator,info) == data:= --CAR name.4 contains all the names except itself --hence we need to add this on, by the above CONS - ['CONS,['CONS,mkDomainConstructor instantiator,['CAR,['ELT,name,4]]], + ['CONS,['CONS,mkTypeForm instantiator,['CAR,['ELT,name,4]]], name] data:= ['SETQ,'TrueDomain,['CONS,data,'TrueDomain]] TruthP info => data |