diff --git a/ChangeLog b/ChangeLog index a8432f7cc..352d2f8ec 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,28 @@ +2024-04-30 Waldek Hebisch + + * src/interp/br-con.boot, src/interp/br-data.boot, + src/interp/br-saturn.boot, src/interp/br-search.boot, + src/interp/br-util.boot, src/interp/c-doc.boot, + src/interp/c-util.boot, src/interp/compiler.boot, + src/interp/define.boot, src/interp/format.boot, + src/interp/g-cndata.boot, src/interp/g-timer.boot, + src/interp/ht-util.boot, src/interp/i-analy.boot, + src/interp/i-coerce.boot, src/interp/i-funsel.boot, + src/interp/i-intern.boot, src/interp/i-map.boot, + src/interp/i-output.boot, src/interp/i-spec2.boot, + src/interp/i-syscmd.boot, src/interp/i-toplev.boot, + src/interp/info.boot, src/interp/int-top.boot, + src/interp/interop.boot, src/interp/lisplib.boot, + src/interp/macros.lisp, src/interp/msgdb.boot, + src/interp/ncomp.boot, src/interp/nlib.lisp, + src/interp/nruncomp.boot, src/interp/postpar.boot, + src/interp/scan.boot, src/interp/setq.lisp, + src/interp/setvart.boot, src/interp/showimp.boot, + src/interp/trace.boot, src/interp/util.lisp, + src/lisp/Makefile.in, src/lisp/fricas-lisp.lisp, + src/lisp/fricas-package.lisp, src/scripts/build_helper: + Misc cleanups + 2024-04-29 Waldek Hebisch * src/interp/c-util.boot: Downgrade two errors to warnings diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index af775dd93..de720ad09 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -69,29 +69,6 @@ conPageConEntry entry == kxPage(htPage,name) == downlink name -kdPageInfo(name,abbrev,nargs,conform,signature,file?) == - htSay('"{\sf ",name,'"}") - if abbrev ~= name then bcHt ['" has abbreviation ",abbrev] - if file? then bcHt ['" is a source file."] - if nargs = 0 then (if abbrev ~= name then bcHt '".") - else - if abbrev ~= name then bcHt '" and" - bcHt - nargs = 1 => '" takes one argument:" - ['" takes ",STRINGIMAGE nargs,'" arguments:"] - htSayStandard '"\indentrel{2}" - if nargs > 0 then kPageArgs(conform,signature) - htSayStandard '"\indentrel{-2}" - if name.(#name-1) = char "&" then name := SUBSEQ(name, 0, #name-1) - sourceFileName := get_database(INTERN(name), 'SOURCEFILE) - filename := extractFileNameFromPath sourceFileName - if filename ~= '"" then - htSayStandard '"\newline{}" - htSay('"The source code for the constructor is found in ") - htMakePage [['text,'"\unixcommand{",filename,'"}{_\$FRICAS/lib/SPADEDIT ", - sourceFileName, '" ", name, '"}"]] - if nargs ~= 0 then htSay '"." - kArgPage(htPage,arg) == [op,:args] := conform := htpProperty(htPage,'conform) domname := htpProperty(htPage,'domname) @@ -107,40 +84,8 @@ kArgPage(htPage,arg) == ('(First Second Third Fourth Fifth)).n htpSetProperty(htPage,'rank,rank) htpSetProperty(htPage,'thing,'"argument") ---htpSetProperty(htPage,'specialMessage,['reportCategory,conform,typeForm,arg]) dbShowCons(htPage,'names) -reportCategory(conform,typeForm,arg) == - htSay('"Argument {\em ",arg,'"}") - [conlist, :oplist] := categoryParts(conform,typeForm,true) - htSay '" must " - if conlist then - htSay '"belong to " - if conlist is [u] then - htSay('"category ") - bcConform first u - bcPred rest u - else - htSay('"categories:") - bcConPredTable(conlist,opOf conform) - htSay '"\newline " - if oplist then - if conlist then htSay '" and " - report_ops(oplist) - -report_ops(oplist) == - htSayList(['"have ", '"operation", '":"]) - for [op,sig,:pred] in oplist repeat - htSay('"\newline ") - if #oplist = 1 then htSay('"\centerline{") - ops := escapeSpecialChars STRINGIMAGE op - sigs := form2HtString ['Mapping,:sig] - satDownLink(ops,['"(|opPage| '|",ops,'"| |",sigs,'"|)"]) - htSay('": ") - bcConform ['Mapping,:sig] - if #oplist = 1 then htSay('"}") - htSay '"\newline " - mkDomTypeForm(typeForm,conform,domname) == --called by kargPage domname => SUBLISLIS(rest domname,rest conform,typeForm) typeForm is ['Join,:r] => ['Join,:[mkDomTypeForm(t,conform,domname) for t in r]] @@ -177,17 +122,6 @@ domainDescendantsOf(conform,domform) == main where --called by kargPage -- Branches of Constructor Page --======================================================================= -kiPage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conform := mkConform(kind,name,args) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := ['"Description of ", capitalize kind,'" {\sf ",name,args,'"}"] - page := htInitPage(heading,htCopyProplist htPage) - $conformsAreDomains := domname - dbShowConsDoc1(htPage,conform,nil) - htShowPage() - kePage(htPage,junk) == [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) constring := STRCONC(name,args) @@ -757,12 +691,9 @@ dbShowCons1(htPage,cAlist,key) == --key = 'catfilter => dbShowCatFilter(page,key) key = 'names => bcNameConTable conlist key = 'abbrs => - bcAbbTable [getCDTEntry(con,true) for con in conlist] - key = 'files => - flist := - [y for con in conlist | - y := (fn := get_database(con, 'SOURCEFILE))] - bcUnixTable(listSort(function GLESSEQP,REMDUP flist)) + bcAbbTable(page, [[con ,get_database(con, 'ABBREVIATION)] + for con in conlist]) + key = 'files => BREAK() key = 'documentation => dbShowConsDoc(page,conlist) if $exposedOnlyIfTrue then cAlist := [x for x in cAlist | isExposedConstructor opOf first x] @@ -877,19 +808,6 @@ dbShowConstructorLines lines == cAlist := [[getConstructorForm intern dbName line,:true] for line in lines] dbShowCons1(nil,listSort(function GLESSEQP,cAlist),'names) -bcUnixTable(u) == - htSay '"\newline" - htBeginTable() - for x in u repeat - htSay '"{" - ft := - isAsharpFileName? x => '("AS") - '("SPAD") - filename := NAMESTRING find_file(STRINGIMAGE x, ft) - htMakePage [['text, '"\unixcommand{",PATHNAME_-NAME x, '"}{$FRICAS/lib/SPADEDIT ", filename, '"} "]] - htSay '"}" - htEndTable() - isAsharpFileName? con == false --======================================================================= diff --git a/src/interp/br-data.boot b/src/interp/br-data.boot index fbe3dd300..08b39a3a4 100644 --- a/src/interp/br-data.boot +++ b/src/interp/br-data.boot @@ -380,7 +380,7 @@ getDefaultPackageClients con == --called by mkUsersHashTable catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) for [catAncestor,:.] in childrenOf([catname]) repeat pakname := INTERN STRCONC(PNAME catAncestor,'"&") - if getCDTEntry(pakname,true) then acc := [pakname,:acc] + if get_database(pakname, 'ABBREVIATION) then acc := [pakname,:acc] acc := union([CAAR x for x in domainsOf([catAncestor],nil)],acc) listSort(function GLESSEQP,acc) @@ -712,7 +712,8 @@ $defaultPackageNamesHT := buildDefaultPackageNamesHT() --======================================================================= -- Code for Private Libdbs --======================================================================= --- $createLocalLibDb := false +$createLocalLibDb := false +$newConstructorList := [] extendLocalLibdb conlist == -- called by astran not $createLocalLibDb => nil diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot index 0fdedb290..ab1970835 100644 --- a/src/interp/br-saturn.boot +++ b/src/interp/br-saturn.boot @@ -45,11 +45,6 @@ page() == $curPage htSay(x) == bcHt(x) -htSayCold x == - htSay '"\lispLink{}{" - htSay x - htSay '"}" - htSayStandard(x) == --do AT MOST for $standard bcHt(x) @@ -145,7 +140,6 @@ htMakePage1 itemList == itemType = 'inputStrings => htInputStrings items itemType = 'domainConditions => htProcessDomainConditions items itemType = 'bcStrings => htProcessBcStrings items - itemType = 'toggleButtons => htProcessToggleButtons items itemType = 'bcButtons => htProcessBcButtons items itemType = 'doneButton => htProcessDoneButton items itemType = 'doitButton => htProcessDoitButton items @@ -877,7 +871,3 @@ screenLocalLine(line, conlist) == dbName line MEMQ(con, conlist) ---------------> NEW DEFINITION (see br-data.boot) -purgeLocalLibdb() == --called by the user through a clear command? - $newConstructorList := nil - deleteFile '"libdb.text" diff --git a/src/interp/br-search.boot b/src/interp/br-search.boot index b9060e575..b32c16a14 100644 --- a/src/interp/br-search.boot +++ b/src/interp/br-search.boot @@ -84,24 +84,6 @@ dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x -grepForAbbrev(s,key) == ---checks that filter s is not * and is all uppercase; if so, look for abbrevs - u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first - s := STRINGIMAGE s - someLowerCaseChar := false - someUpperCaseChar := false - for i in 0..MAXINDEX s repeat - c := s . i - LOWER_-CASE_-P c => return (someLowerCaseChar := true) - UPPER_-CASE_-P c => someUpperCaseChar := true - someLowerCaseChar or not someUpperCaseChar => false - pattern := DOWNCASE s - ['Abbreviations, :[get_database(x, 'CONSTRUCTORFORM) - for x in allConstructors() | test]] where test == - not $includeUnexposed? and not isExposedConstructor x => false - a := get_database(x, 'ABBREVIATION) - match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) - applyGrep(x,filename) == atom x => grepFile(x,filename,'i) $localLibdb => @@ -537,18 +519,6 @@ removeSurroundingStars filter == showNamedDoc([kind,:lines],index) == dbGather(kind,lines,index - 1,true) -sayDocMessage message == - htSay('"{\em ") - if message is [leftEnd,left,middle,right,rightEnd] then - htSayList([leftEnd, left, '"}"]) - if left ~= '"" and left.(MAXINDEX left) = $blank then htBlank() - htSay middle - if right ~= '"" and right.0 = $blank then htBlank() - htSayList(['"{\em ", right, rightEnd]) - else - htSay message - htSay ('"}") - stripOffSegments(s,n) == progress := true while n > 0 and progress = true repeat @@ -759,7 +729,7 @@ detailedSearch(filter) == -- doc) ) (text . "\vspace{1}\newline\centerline{ ") - (bcLinks ("\box{Search}" "" generalSearchDo NIL)) + (bcLinks ("\fbox{Search}" "" generalSearchDo NIL)) (text . "}")) htShowPage() diff --git a/src/interp/br-util.boot b/src/interp/br-util.boot index 9e5bab1d0..9f28c190b 100644 --- a/src/interp/br-util.boot +++ b/src/interp/br-util.boot @@ -59,7 +59,6 @@ $docTable := nil --cache for documentation table $conArgstrings := nil --bound by conPage so that kPage --will display arguments if given $conformsAreDomains := false --are all arguments of a constructor given? -$returnNowhereFromGoGet := false --special branch out for goget for browser $dbDataFunctionAlist := nil --set by dbGatherData $domain := nil --bound in koOps $predvec := nil --bound in koOps @@ -393,14 +392,6 @@ extractFileNameFromPath s == fn(s,0,#s) where k = m => SUBSTRING(s,i,nil) fn(s,k + 1,m) -bcOpTable(u,fn) == - htBeginTable() - for op in u for i in 0.. repeat - htSay '"{" - htMakePage [['bcLinks,[escapeSpecialChars STRINGIMAGE opOf op,'"",fn,i]]] - htSay '"}" - htEndTable() - bcNameConTable u == $bcMultipleNames: local := (#u ~= 1) bcConTable REMDUP u @@ -465,16 +456,6 @@ splitConTable cons == cond := [pair,:cond] [NREVERSE uncond,:NREVERSE cond] -bcNameTable(u,fn,:option) == --option if * prefix - htSay '"\newline" - htBeginTable() - for x in u repeat - htSay '"{" - if IFCAR option then bcStar x - htMakePage [['bcLinks,[s := escapeSpecialChars STRINGIMAGE x,'"",fn,s]]] - htSay '"}" - htEndTable() - bcNameCountTable(u, fn, gn) == linkFunction := 'bcLispLinks htSay '"\newline" @@ -485,11 +466,6 @@ bcNameCountTable(u, fn, gn) == htSay '"}" htEndTable() -dbSayItemsItalics(:u) == - htSay '"{\em " - APPLY(function dbSayItems,u) - htSay '"}" - dbSayItems(countOrPrefix,singular,plural,:options) == bcHt '"\newline " count := @@ -556,12 +532,6 @@ errorPage(htPage,[heading,kind,:info]) == htErrorStar() == errorPage(nil,['"{\em *} not a valid search string",nil,'"\vspace{3}\centerline{{\em *} is not a valid search string for a general search}\centerline{\em {it would match everything!}}"]) -htQueryPage(htPage,heading,message,query,fn) == - htInitPage(heading,nil) - htSay message - htQuery(query, fn, false) - htShowPage() - htQuery(question, fn, upLink?) == if question then htSay('"\vspace{1}\centerline{") @@ -651,8 +621,6 @@ bcOptional s == s = '"" => '"2" s -bcvspace() == bcHt '"\vspace{1}\newline " - bcString2WordList s == fn(s,0,MAXINDEX s) where fn(s,i,n) == i > n => nil diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot index 2197ed446..ec4f9d029 100644 --- a/src/interp/c-doc.boot +++ b/src/interp/c-doc.boot @@ -155,28 +155,6 @@ transDoc(conname,doclist) == checkDocError1 ['"Not documented!!!!"] u := checkTrim($x,(STRINGP lines => [lines]; $x = 'constructor => first lines; lines)) $argl : local := nil --set by checkGetArgs --- tpd: related domain information doesn't exist --- if v := checkExtract('"Related Domains:",u) then --- $lisplibRelatedDomains:=[w for x in gn(v) | w := fn(x)] where --- gn(v) == --note: unabbrev checks for correct number of arguments --- s := checkExtractItemList v --- parse := ncParseFromString s --is a single conform or a tuple --- null parse => nil --- parse is ['Tuple,:r] => r --- [parse] --- fn(x) == --- expectedNumOfArgs := checkNumOfArgs x --- null expectedNumOfArgs => --- checkDocError ['"Unknown constructor name?: ",opOf x] --- x --- expectedNumOfArgs ~= (n := #(IFCDR x)) => --- n = 0 => checkDocError1 --- ['"You must give arguments to the _"Related Domain_": ",x] --- checkDocError --- ['"_"Related Domain_" has wrong number of arguments: ",x] --- nil --- n=0 and atom x => [x] --- x longline := $x = 'constructor => v :=checkExtract('"Description:",u) or u and @@ -478,8 +456,7 @@ checkComments(nameSig,lines) == main where main == $checkErrorFlag: local := false margin := checkGetMargin lines - if (null BOUNDP '$attribute? or null $attribute?) - and nameSig ~= 'constructor then lines := + if not($attribute?) and nameSig ~= 'constructor then lines := [checkTransformFirsts(first nameSig,first lines,margin),:rest lines] u := checkIndentedLines(lines, margin) $argl := checkGetArgs first u --set $argl diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 94aaf37d7..e36a20af2 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -31,18 +31,23 @@ )package "BOOT" ---% Debugging Functions +$genSDVar := 0 -level(:l) == - null l => same() - l is [n] and INTEGERP n => displayComp ($level:= n) - SAY '"Correct format: (level n) where n is the level you want to go to" +$previousTime := 0 -up() == displayComp ($level:= $level-1) +$warningStack := [] +$semanticErrorStack := [] -same() == displayComp $level +DROP(n, l) == + n >= 0 => + while n > 0 repeat + l := rest(l) + l + TAKE(#l + n, l) -down() == displayComp ($level:= $level+1) +TAKE(n, l) == + n >= 0 => [x for x in l for i in 1..n] + DROP(#l + n, l) displaySemanticErrors() == n:= #($semanticErrorStack:= REMDUP $semanticErrorStack) @@ -79,12 +84,11 @@ displayComp level == --mathprint removeZeroOne mkErrorExpr level pp removeZeroOne mkErrorExpr level sayBrightly ['"****** level",'%b,level,'%d,'" ******"] - [$x, $m, $f, $exitModeStack] := $s.(level - 1) - ($X:=$x;$M:=$m;$F:=$f) - SAY('"$x:= ",$x) - SAY('"$m:= ",$m) - SAY '"$f:=" - limited_print1_stdout($f) + [x, m, f, $exitModeStack] := $s.(level - 1) + SAY('"x:= ", x) + SAY('"m:= ", m) + SAY '"f:=" + limited_print1_stdout(f) nil mkErrorExpr level == @@ -605,67 +609,11 @@ subst_in_cat(fp, ap, cv) == pp := MAPCAR(FUNCTION CONS, fp, ap) sublis_vec(pp, cv) ---% DEBUGGING PRINT ROUTINES used in breaks - -_?MODEMAPS x == _?modemaps x -_?modemaps x == - env:= - $insideCapsuleFunctionIfTrue=true => $CapsuleModemapFrame - $f - x="all" => displayModemaps env - -- displayOpModemaps(x,old2NewModemaps get(x,"modemap",env)) - displayOpModemaps(x,get(x,"modemap",env)) - - old2NewModemaps x == -- [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] x is [dcSig,[pred,:.],:.] => [dcSig,pred] x -traceUp() == - atom $x => sayBrightly '"$x is an atom" - for y in rest $x repeat - u:= comp(y,$EmptyMode,$f) => - sayBrightly [y,'" ==> mode",'%b,u.mode,'%d] - sayBrightly [y,'" does not compile"] - -_?m x == - u:= comp(x,$EmptyMode,$f) => u.mode - nil - -traceDown() == - mmList:= getFormModemaps($x,$f) => - for mm in mmList repeat if u:= qModemap mm then return u - sayBrightly '"no modemaps for $x" - -qModemap mm == - sayBrightly ['%b,"modemap",'%d,:formatModemap mm] - [[dc,target,:sl],[pred,:.]]:= mm - and/[qArg(a,m) for a in rest $x for m in sl] => target - sayBrightly ['%b,'"fails",'%d,'%l] - -qArg(a,m) == - yesOrNo:= - u:= comp(a,m,$f) => "yes" - "no" - sayBrightly [a,'" --> ",m,'%b,yesOrNo,'%d] - yesOrNo="yes" - -_?comp x == - msg:= - u:= comp(x,$EmptyMode,$f) => - [MAKESTRING '"compiles to mode",'%b,u.mode,'%d] - nil - sayBrightly msg - -_?domains() == pp getDomainsInScope $f - -_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]]) - -_?properties x == displayProplist(x,getProplist(x,$f)) - -_?value x == displayProplist(x,[["value",:get(x,"value",$f)]]) - displayProplist(x,alist) == sayBrightly ['"properties of",'%b,x,'%d,'":"] fn alist where diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index b1ec9a59f..7cc84c8f0 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -31,6 +31,14 @@ )package "BOOT" +$bootStrapMode := false +$compUniquelyIfTrue := false +$exitMode := $EmptyMode +$exitModeStack := [] +$leaveLevelStack := [] + +$returnMode := $EmptyMode + init_compiler_properties() == for sv in [ _ ["|", "compSuchthat"], ["@", "compAtSign"], _ @@ -1387,15 +1395,12 @@ compileSpad2Cmd args == -- should be unhooked $scanIfTrue : local := nil - $f : local := nil -- compiler - $m : local := nil -- variables -- following are for )quick option for code generation $QuickLet : local := true $QuickCode : local := true - fun := ['rq, 'lib] - constructor := nil + lib := true for opt in $options repeat [optname,:optargs] := opt @@ -1404,46 +1409,24 @@ compileSpad2Cmd args == fullopt = 'new => error '"Internal error: compileSpad2Cmd got )new" fullopt = 'old => NIL -- no opt - fullopt = 'library => fun.1 := 'lib - fullopt = 'nolibrary => fun.1 := 'nolib + fullopt = 'library => lib := true + fullopt = 'nolibrary => lib := false -- Ignore quiet/nonquiet if "constructor" is given. - fullopt = 'quiet => if fun.0 ~= 'c then fun.0 := 'rq - fullopt = 'noquiet => if fun.0 ~= 'c then fun.0 := 'rf + fullopt = 'quiet => "ignored now" + fullopt = 'noquiet => "ignored now" fullopt = 'nobreak => $scanIfTrue := true fullopt = 'break => $scanIfTrue := nil fullopt = 'vartrace => $QuickLet := false - fullopt = 'lisp => - throwKeyedMsg("S2IZ0036",['")lisp"]) - fullopt = 'functions => - null optargs => - throwKeyedMsg("S2IZ0037",['")functions"]) - throwKeyedMsg('")functions unsupported", []) - fullopt = 'constructor => - null optargs => - throwKeyedMsg("S2IZ0037",['")constructor"]) - fun.0 := 'c - constructor := [unabbrev o for o in optargs] throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) - $InteractiveMode : local := nil - compilerDoit(constructor, fun) + compilerDoit(lib, path) extendLocalLibdb $newConlist terminateSystemCommand() spadPrompt() -compilerDoit(constructor, fun) == - $byConstructors : local := [] - $constructorsSeen : local := [] - fun = ['rf, 'lib] => read_or_compile(true, true) -- Ignore "noquiet". - fun = ['rf, 'nolib] => read_or_compile(false, false) - fun = ['rq, 'lib] => read_or_compile(true, true) - fun = ['rq, 'nolib] => read_or_compile(true, false) - fun = ['c, 'lib] => - $byConstructors := [opOf x for x in constructor] - read_or_compile(true, true) - for ii in $byConstructors repeat - null member(ii,$constructorsSeen) => - sayBrightly ['">>> Warning ",'%b,ii,'%d,'" was not found"] - +compilerDoit(lib, path) == + $InteractiveMode : local := nil + $LISPLIB : local := lib + spadCompile(path) diff --git a/src/interp/define.boot b/src/interp/define.boot index 48fa27f1e..909d77391 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -32,6 +32,13 @@ )package "BOOT" DEFPARAMETER($newCompCompare, false) +$insideCategoryPackageIfTrue := false +$insideCapsuleFunctionIfTrue := false +$insideCategoryIfTrue := false +$insideWhereIfTrue := false + +$functorLocalParameters := [] +$functorForm := nil --% FUNCTIONS WHICH MUNCH ON == STATEMENTS @@ -1184,7 +1191,7 @@ compCategoryItem(x, predl, acc) == compCategoryItem(c, predl', acc) pred:= (predl => MKPF(predl,"AND"); true) - --2. if attribute, push it and return + --2. if conditional category, push it and return x is ["ATTRIBUTE", 'nil] => BREAK() x is ["ATTRIBUTE", y] => -- should generate something else for conditional categories diff --git a/src/interp/format.boot b/src/interp/format.boot index e9375caec..acf9652be 100644 --- a/src/interp/format.boot +++ b/src/interp/format.boot @@ -33,6 +33,9 @@ --% Functions for display formatting system objects +$abbreviateJoin := false +$whereList := nil + --% Formatting modemaps sayModemap m == @@ -294,6 +297,8 @@ prefix2String form == prefix2String0 form == form2StringLocal form +$permitWhere := false + form2StringWithWhere u == $permitWhere : local := true $whereList: local := nil diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot index ff8531fda..bec7fe466 100644 --- a/src/interp/g-cndata.boot +++ b/src/interp/g-cndata.boot @@ -49,15 +49,6 @@ augmentLowerCaseConTable x == HPUT($lowerCaseConTb,DOWNCASE x,item) HPUT($lowerCaseConTb,y,item) -getCDTEntry(info,isName) == - not IDENTP info => NIL - (entry := HGET($lowerCaseConTb,info)) => - [name,abb,:.] := entry - isName and EQ(name,info) => entry - not isName and EQ(abb,info) => entry - NIL - entry - abbreviation? abb == -- if it is an abbreviation, return the corresponding name get_database(abb, 'CONSTRUCTOR) @@ -101,7 +92,6 @@ abbQuery(x) == sayKeyedMsg("S2IZ0003",[x]) installConstructor(cname) == - (entry := getCDTEntry(cname,true)) => entry item := [cname, get_database(cname, 'ABBREVIATION), nil] if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then HPUT($lowerCaseConTb,cname,item) diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot index 27ecb7fc2..24839481b 100644 --- a/src/interp/g-timer.boot +++ b/src/interp/g-timer.boot @@ -36,6 +36,8 @@ -- named stats (listofnames) grouped in classes (listofclasses) -- and with measurement types (property). +$timerTicksPerSecond := INTERNAL_-TIME_-UNITS_-PER_-SECOND + makeLongStatStringByProperty _ (listofnames, listofclasses, property, units, flag) == total := 0 diff --git a/src/interp/ht-util.boot b/src/interp/ht-util.boot index 3c3ea93d2..09ffb990c 100644 --- a/src/interp/ht-util.boot +++ b/src/interp/ht-util.boot @@ -213,25 +213,6 @@ stringize s == STRINGP s => s PRINC_-TO_-STRING s - -htQuote s == --- wrap quotes around a piece of hyperTeX - iht '"_"" - iht s - iht '"_"" - -htProcessToggleButtons buttons == - iht '"\newline\indent{5}\beginitems " - for [message, info, defaultValue, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - iht '"\enditems\indent{0} " - htProcessBcButtons buttons == for [defaultValue, buttonName] in buttons repeat if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then @@ -369,20 +350,6 @@ pvarsOfPattern pattern == NULL LISTP pattern => nil [pvar for pvar in rest pattern | pvar in $PatternVariableList] -htMakeTemplates(templateList, numLabels) == - templateList := [templateParts template for template in templateList] - [[substLabel(i, template) for template in templateList] - for i in 1..numLabels] where substLabel(i, template) == - PAIRP template => - INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template) - template - -templateParts template == - NULL STRINGP template => template - i := SEARCH('"%l", template) - null i => template - [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)] - htMakeDoneButton(message, func) == bcHt '"\newline\vspace{1}\centerline{" if message = '"Continue" then diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot index f78d0818b..302205bd0 100644 --- a/src/interp/i-analy.boot +++ b/src/interp/i-analy.boot @@ -553,6 +553,8 @@ bottomUpForm0(t,op,opName,argl,argModeSetList) == (opName ~= "elt") and (opName ~= "apply") and isEltable(op, argl, #argl) and (u := bottomUpElt t) => u + $noEvalTypeMsg => spadThrow() + amsl := printableArgModeSetList() opName1 := opName0 = $immediateDataSymbol => diff --git a/src/interp/i-coerce.boot b/src/interp/i-coerce.boot index 631fa5cf8..efdbe5ffc 100644 --- a/src/interp/i-coerce.boot +++ b/src/interp/i-coerce.boot @@ -59,6 +59,10 @@ The special routines that do the coercions typically involve a "2" Note that the special routines are in the file COERCEFN BOOT. )endif +$useCoerceOrCroak := true +$insideCanCoerceFrom := false +$useConvertForCoercions := false + --% Algebraic coercions using interactive code algCoerceInteractive(p,source,target) == diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot index 06d37b981..96f91b71d 100644 --- a/src/interp/i-funsel.boot +++ b/src/interp/i-funsel.boot @@ -51,6 +51,8 @@ the following flags are used: if $SubDom is true, then runtime checks have to be compiled )endif +$domPvar := nil + sayFunctionSelection(op,args,target,dc,func) == $abbreviateTypes : local := true startTimingProcess 'debug diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot index dcc0e58bb..1a0ef50ea 100644 --- a/src/interp/i-intern.boot +++ b/src/interp/i-intern.boot @@ -59,6 +59,7 @@ DEFPARAMETER($useParserSrcPos, NIL) DEFPARAMETER($transferParserSrcPos, NIL) DEFCONST($failure, GENSYM()) +DEFCONSTANT($immediateDataSymbol, "--immediateData--") -- Making Trees @@ -551,10 +552,6 @@ getModeSetUseSubdomain x == --% Environment Utilities --- getValueFromEnvironment(x,mode) == --- $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v --- $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v --- throwKeyedMsg("S2IE0001",[x]) getValueFromEnvironment(x,mode) == $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot index 446215098..f30960537 100644 --- a/src/interp/i-map.boot +++ b/src/interp/i-map.boot @@ -33,6 +33,7 @@ --% User Function Creation and Analysis Code +$insideCompileBodyIfTrue := false DEFPARAMETER($mapTarget, nil) DEFPARAMETER($mapReturnTypes, nil) DEFPARAMETER($mapName, 'noMapName) diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot index f97c7fcb2..95065bc51 100644 --- a/src/interp/i-output.boot +++ b/src/interp/i-output.boot @@ -212,6 +212,11 @@ DEFVAR($texFormat, false) -- if true produce tex output DEFVAR($texmacsFormat, false) -- if true produce Texmacs output DEFVAR($formattedFormat, false) -- if true produce formatted output +$LINELENGTH := 77 +$MARGIN := 3 +DEFCONST(BLANK, '" ") +DEFCONST(UNDERBAR, '"__") + makeCharacter n == INTERN(NUM2USTR(n)) DEFPARAMETER($RTspecialCharacters, [ @@ -1986,14 +1991,17 @@ bracketagglist(u, start, linelength, tchr, open, close) == [LIST('CONCAT, '" ", y) for y in rest u] ) repeat s := 0 + prev_x := nil + last_x := nil for x in tails u repeat - lastx := x + prev_x := last_x + last_x := x ((s := s + WIDTH first x + 1) >= linelength) => return(s) null rest x => return(s := -1) nil or EQ(s, -1) => (nextu := nil) - EQ(lastx, u) => ((nextu := rest u); RPLACD(u, nil) ) - true => ((nextu := lastx); RPLACD(PREDECESSOR(lastx, u), nil)) + EQ(last_x, u) => ((nextu := rest u); RPLACD(u, nil) ) + true => ((nextu := last_x); RPLACD(prev_x, nil)) for x in tails u repeat RPLACA(x, LIST('CONCAT, first x, tchr)) if null nextu then RPLACA(CDDR last u, close) diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot index 14fc60a62..b632a234a 100644 --- a/src/interp/i-spec2.boot +++ b/src/interp/i-spec2.boot @@ -191,7 +191,7 @@ uplocalWithType(var,type) == uphas t == t isnt [op,type,prop] => nil - -- handler for category and attribute queries + -- handler for category queries type := isLocalVar(type) => ['unabbrev, type] MKQ unabbrev type diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index e56eb497f..925e23c9e 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -36,6 +36,12 @@ -- TRACE BOOT. The list of system commands is $SYSCOMMANDS which is -- initialized in SETQ LISP. +$newConlist := [] +$edit_file := nil +$currentLine := '"" +$HiFiAccess := true +$reportUndo := false + --% Utility Variable Initializations DEFPARAMETER($compileRecurrence, true) @@ -224,11 +230,11 @@ listConstructorAbbreviations() == cd(args) == dname := null(args) => - TRIM_-DIRECTORY_-NAME(NAMESTRING(USER_-HOMEDIR_-PATHNAME())) + trim_directory_name(NAMESTRING(USER_-HOMEDIR_-PATHNAME())) first(args) if SYMBOLP(dname) then dname := SYMBOL_-NAME(dname) CHDIR(dname) - sayKeyedMsg("S2IZ0070", [GET_-CURRENT_-DIRECTORY()]) + sayKeyedMsg("S2IZ0070", [get_current_directory()]) --% )clear @@ -534,7 +540,7 @@ compileAsharpArchiveCmd args == -- the name is fully qualified. path := first(args) - FILE_-KIND(path) ~= 1 => + file_kind(path) ~= 1 => throwKeyedMsg("S2IL0003", [path]) -- here is the plan: @@ -547,7 +553,7 @@ compileAsharpArchiveCmd args == -- First try to make the directory in the current directory dir := fnameMake('".", pathnameName path, '"axldir") - isDir := FILE_-KIND namestring dir + isDir := file_kind(namestring(dir)) isDir = 0 => throwKeyedMsg("S2IL0027",[namestring dir, path]) @@ -555,7 +561,7 @@ compileAsharpArchiveCmd args == rc := makedir namestring dir rc ~= 0 => throwKeyedMsg("S2IL0027", [namestring dir, path]) - curDir := GET_-CURRENT_-DIRECTORY() + curDir := get_current_directory() -- cd to that directory and try to unarchive the .al file @@ -2079,7 +2085,7 @@ ScanOrPairVec(f, ob) == library(args) == $newConlist : local := [] - original_directory := GET_-CURRENT_-DIRECTORY() + original_directory := get_current_directory() merge_info_from_objects(args, $options, false) extendLocalLibdb($newConlist) CHDIR(original_directory) @@ -2185,15 +2191,14 @@ readSpad2Cmd l == do_read(ll, quiet, pile_mode) == $nopiles : local := pile_mode $edit_file := ll - read_or_compile(quiet, false) + read_or_compile(quiet, ll) terminateSystemCommand() spadPrompt() basename(x) == NAMESTRING(PATHNAME_-NAME(x)) -read_or_compile(quiet, lib) == - $LISPLIB : local := lib - input_file := make_input_filename($edit_file) +read_or_compile(quiet, i_name) == + input_file := make_input_filename(i_name) type := PATHNAME_-TYPE(input_file) type = '"boot" => lfile := CONCAT(basename(input_file), '".clisp") @@ -2201,10 +2206,9 @@ read_or_compile(quiet, lib) == LOAD(COMPILE_-FILE(lfile)) type = '"lisp" => ffile := CONCAT(basename(input_file), ".", $lisp_bin_filetype) - LOAD(FRICAS_COMPILE_FASL(input_file, ffile)) + LOAD(fricas_compile_fasl(input_file, ffile)) type = '"bbin" => LOAD(input_file) type = '"input" => ncINTERPFILE(input_file, not(quiet)) - spadCompile(input_file) --% )show diff --git a/src/interp/i-toplev.boot b/src/interp/i-toplev.boot index 7ad594f79..8f263d9a4 100644 --- a/src/interp/i-toplev.boot +++ b/src/interp/i-toplev.boot @@ -39,6 +39,8 @@ --% Top Level Interpreter Code +$interpOnly := false + -- When $QuiteCommand is true Spad will not produce any output from -- a top level command DEFPARAMETER($QuietCommand, NIL) @@ -55,6 +57,79 @@ intUnsetQuiet() == --% Starting the interpreter from LISP +-- The relative directory list specifies a search path for files +-- for the current directory structure. + +$relative_directory_list := '("share/msgs/" "share/spadhelp/") +-- The relative directory list specifies how to find the algebra +-- directory from the current {\bf FRICAS} shell variable. +$relative_library_directory_list := '("algebra/") + +-- This is the system-wide list of directories to search. +-- It is set up in the {\bf reroot} function. +$directory_list := [] + +-- This is the system-wide search path for library files. +-- It is set up in the {\bf reroot} function. +$library_directory_list := [] + +)if false +The reroot function is used to reset the important variables used by +the system. In particular, these variables are sensitive to the +{\bf FRICAS} shell variable. That variable is renamed internally to +be {\bf |$spadroot|}. The {\bf reroot} function will change the +system to use a new root directory and will have the same effect +as changing the {\bf FRICAS} shell variable and rerunning the system +from scratch. +)endif + +$spadroot := '"" + +-- Prefix a filename with the {\bf |$spadroot|} variable. +make_absolute_filename(name) == STRCONC($spadroot, '"/", name) + +reroot(dir) == + $spadroot := dir + $directory_list := MAPCAR(function make_absolute_filename, + $relative_directory_list) + $library_directory_list := MAPCAR(function make_absolute_filename, + $relative_library_directory_list) + $defaultMsgDatabaseName := + make_absolute_filename('"share/msgs/s2-us.msgs") + +initroot() == + spadroot := getEnv('"FRICAS") + if not(spadroot) then + bin_parent_dir := STRCONC(DIRECTORY_-NAMESTRING(first(getCLArgs())), + '"/../") + if fricas_probe_file(STRCONC(binparent_dir, '"algebra/interp.daase")) + then spadroot := bin_parent_dir + else ERROR("Environment variable FRICAS is not set!") + spadroot := fricas_probe_file(spadroot) + if spadroot then + reroot(trim_directory_name(NAMESTRING(spadroot))) + else + ERROR('"Environment variable FRICAS is not valid!") + +$trace_stream := nil +CUROUTSTREAM := nil + +fricas_restart() == + -- Need to reinitialize various streams because + -- CLISP closes them when dumping executable + CUROUTSTREAM := $trace_stream := get_lisp_std_out() + $algebraOutputStream := mkOutputConsoleStream() + $fortranOutputStream := mkOutputConsoleStream() + $mathmlOutputStream := mkOutputConsoleStream() + $texmacsOutputStream := mkOutputConsoleStream() + $htmlOutputStream := mkOutputConsoleStream() + $openMathOutputStream := mkOutputConsoleStream() + $texOutputStream := mkOutputConsoleStream() + $formattedOutputStream := mkOutputConsoleStream() + fricas_init() + fricas_restart2() + + interpsysInitialization(display_messages) == -- The function start begins the interpreter process, reading in -- the profile and printing start-up messages. @@ -117,7 +192,7 @@ readSpadProfileIfThere() == NIL efile => $edit_file := efile - read_or_compile(true, false) + read_or_compile(true, efile) NIL --% Parser Output --> Interpreter diff --git a/src/interp/info.boot b/src/interp/info.boot index 7326c7ca2..806fa6348 100644 --- a/src/interp/info.boot +++ b/src/interp/info.boot @@ -37,8 +37,6 @@ This code adds various items to the special value of $Information, in order to keep track of all the compiler's information about various categories and similar objects An actual piece of (unconditional) information can have one of 3 forms: - (ATTRIBUTE domainname attribute) - --These are only stored here, should be unused (SIGNATURE domainname operator signature) --These are also stored as 'modemap' properties (has domainname categoryexpression) @@ -50,7 +48,6 @@ Conditional attributes are of the form where the condition looks like a 'has' clause, or the 'and' of several 'has' clauses: (has name categoryexpression) - (has name (ATTRIBUTE attribute)) (has name (SIGNATURE operator signature)) The use of two representations is admitted to be clumsy )endif diff --git a/src/interp/int-top.boot b/src/interp/int-top.boot index 6ba9b99c4..37e6cfcbc 100644 --- a/src/interp/int-top.boot +++ b/src/interp/int-top.boot @@ -190,6 +190,8 @@ setCurrentLine s == RPLACD(LASTNODE(v), u) v +$DALYMODE := false + intloopReadConsole(b, n)== repeat ioHook("startReadLine") diff --git a/src/interp/interop.boot b/src/interp/interop.boot index 79bb28fd3..fe77b8936 100644 --- a/src/interp/interop.boot +++ b/src/interp/interop.boot @@ -31,6 +31,9 @@ )package "BOOT" +-- true signals special case for browser +$returnNowhereFromGoGet := false + -- note domainObjects are now (dispatchVector hashCode . domainVector) -- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr), -- pre oldAxiomCategory is (dispatchVector . (cat form)) diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index b3341827d..9c37eacc6 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -31,7 +31,17 @@ )package "BOOT" +$printLoadMsgs := false + $spadLibFT := 'NRLIB +$LISPLIB := false +$libFile := nil + +$lisplibForm := nil +$lisplibKind := nil +$lisplibModemapAlist := [] +$lisplibModemap := nil +$lisplibOperationAlist := [] --% Standard Library Creation Functions diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp index c3034e262..b3272fc58 100644 --- a/src/interp/macros.lisp +++ b/src/interp/macros.lisp @@ -52,8 +52,6 @@ (defmacro def-boot-val (p val where) `(defparameter ,p ,val ,where)) -(def-boot-val |$timerTicksPerSecond| INTERNAL-TIME-UNITS-PER-SECOND - "scale for get_run_time") (def-boot-val $boxString (concatenate 'string (list (code-char #x1d) (code-char #xe2))) "this string of 2 chars displays as a box") @@ -66,50 +64,9 @@ "switch back into normal font") (def-boot-val |$BreakMode| '|query| "error.boot") - -(def-boot-var |$compUniquelyIfTrue| "Compiler>Compiler.boot") -(def-boot-val |$currentLine| "" "current input line for history") - -(def-boot-var |$exitMode| "???") -(def-boot-var |$exitModeStack| "???") - -(def-boot-var |$fromSpadTrace| "Interpreter>Trace.boot") - -(def-boot-val |$genSDVar| 0 "counter for genSomeVariable" ) - -(def-boot-var |$insideCapsuleFunctionIfTrue| "???") -(def-boot-var |$insideCategoryIfTrue| "???") -(def-boot-var |$insideFunctorIfTrue| "???") -(def-boot-var |$insideWhereIfTrue| "???") - -(def-boot-var |$leaveLevelStack| "???") -(def-boot-var |$libFile| "Compiler>LispLib.boot") -(def-boot-val $LISPLIB nil "whether to produce a lisplib or not") -(def-boot-var |$lisplibForm| "Compiler>LispLib.boot") -(def-boot-var |$lisplibKind| "Compiler>LispLib.boot") -(def-boot-var |$lisplibModemapAlist| "Compiler>LispLib.boot") -(def-boot-var |$lisplibModemap| "Compiler>LispLib.boot") -(def-boot-var |$lisplibOperationAlist| "Compiler>LispLib.boot") - -(def-boot-var |$mapSubNameAlist| "Interpreter>Trace.boot") -(def-boot-var |$mathTrace| "Interpreter>Trace.boot") -(def-boot-var |$mathTraceList| "Controls mathprint output for )trace.") - -(def-boot-var |$postStack| "???") -(def-boot-var |$previousTime| "???") -(def-boot-val |$printLoadMsgs| nil "Interpreter>SetVarT.boot") (def-boot-var |$reportBottomUpFlag| "Interpreter>SetVarT.boot") -(def-boot-var |$returnMode| "???") -(def-boot-var |$semanticErrorStack| "???") (def-boot-val |$SetFunctions| nil "checked in SetFunctionSlots") -(def-boot-var |$topOp| "See displayPreCompilationErrors") -(def-boot-var |$tracedSpadModemap| "Interpreter>Trace.boot") -(def-boot-var |$traceletFunctions| "???") - -(def-boot-var |$warningStack| "???") -(def-boot-val |$whereList| () "referenced in format boot formDecl2String") - (def-boot-val |$inputPromptType| '|step| "checked in MKPROMPT") (def-boot-val |$IOindex| 0 "step counter") @@ -297,20 +254,6 @@ (DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) -(defun DROP (N X &aux m) - "Return a pointer to the Nth cons of X, counting 0 as the first cons." - (COND ((EQL N 0) X) - ((> N 0) (DROP (1- N) (CDR X))) - ((>= (setq m (+ (length x) N)) 0) (take m x)) - ((CROAK (list "Bad args to DROP" N X))))) - -(DEFUN TAKE (N X &aux m) - "Returns a list of the first N elements of list X." - (COND ((EQL N 0) NIL) - ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) - ((>= (setq m (+ (length x) N)) 0) (DROP m x)) - ((CROAK (list "Bad args to DROP" N X))))) - ; 15.4 Substitution of Expressions ;; needed for substNames (always copy) @@ -342,13 +285,6 @@ (defun |set_difference| (l1 l2) (set-difference l1 l2 :test #'equal)) - -(DEFUN PREDECESSOR (TL L) - "Returns the sublist of L whose CDR is EQ to TL." - (COND ((ATOM L) NIL) - ((EQ TL (CDR L)) L) - ((PREDECESSOR TL (CDR L))))) - (defun remdup (l) (remove-duplicates l :test #'equalp)) ; 15.6 Association Lists @@ -423,16 +359,10 @@ ; 22.3.1 Output to Character Streams -(defvar |$sayBrightlyStream| nil "if not nil, gives stream for sayBrightly output") - (defun |get_lisp_std_out| () *standard-output*) (defun |get_lisp_error_out| () *error-output*) -(defvar |$fortranOutputStream|) - -(defvar |$highlightAllowed| nil "Used in BRIGHTPRINT and is a )set variable.") - (defvar |$highlightFontOn| (concat " " |$boldString|) "switch to highlight font") (defvar |$highlightFontOff| (concat |$normalString| " ") diff --git a/src/interp/msgdb.boot b/src/interp/msgdb.boot index e71a9fc27..8c7f934fb 100644 --- a/src/interp/msgdb.boot +++ b/src/interp/msgdb.boot @@ -78,6 +78,10 @@ above for examples. --% Message Database Code and Message Utility Functions +$testingSystem := false +$sayBrightlyStream := nil +$highlightAllowed := false + DEFPARAMETER($testingErrorPrefix, '"Daly Bug") DEFPARAMETER($texFormatting, false) diff --git a/src/interp/ncomp.boot b/src/interp/ncomp.boot index 3830c1d38..bde62326a 100644 --- a/src/interp/ncomp.boot +++ b/src/interp/ncomp.boot @@ -249,7 +249,6 @@ boo_comp1(x) == $topOp : local := nil $semanticErrorStack : local := [] $warningStack : local := [] - $exitMode : local := $EmptyMode $exitModeStack : local := [] $returnMode : local := $EmptyMode $leaveLevelStack : local := [] @@ -333,7 +332,6 @@ S_process(x) == $topOp : local := nil $semanticErrorStack : local := nil $warningStack : local := nil - $exitMode : local := $EmptyMode $exitModeStack : local := [] $returnMode : local := $EmptyMode $leaveLevelStack : local := [] @@ -349,7 +347,6 @@ S_process(x) == $previousTime : local := get_run_time() $s : local := nil $x : local := nil - $m : local := nil null(x) => nil $SaveParseOnly => x := walkForm(x) diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp index c050db597..6ec1ab30a 100644 --- a/src/interp/nlib.lisp +++ b/src/interp/nlib.lisp @@ -55,8 +55,8 @@ (let ((stream nil) (indextable nil) (fullname (|make_full_namestring| file))) - (case (file-kind fullname) - (-1 (makedir fullname)) + (case (|file_kind| fullname) + (-1 (|makedir| fullname)) (0 (error (format nil "~s is an existing file, not a library" fullname))) (1 nil) @@ -183,7 +183,7 @@ entry)) -(defun rshut (rstream) +(defun RSHUT (rstream) (if (eq (libstream-mode rstream) 'output) (|write_indextable| (libstream-indextable rstream) (libstream-indexstream rstream))) @@ -260,13 +260,13 @@ (defun |make_full_namestring| (filearg) (namestring (merge-pathnames (|make_filename| filearg)))) -(defun |get_directory_list| (ft &aux (cd (get-current-directory))) +(defun |get_directory_list| (ft &aux (cd (|get_current_directory|))) (cond ((member ft '("NRLIB" "DAASE") :test #'string=) (if (eq |$UserLevel| '|development|) - (cons cd $library-directory-list) - $library-directory-list)) + (cons cd |$library_directory_list|) + |$library_directory_list|)) (t (adjoin cd - (adjoin (namestring (user-homedir-pathname)) $directory-list + (adjoin (namestring (user-homedir-pathname)) |$directory_list| :test #'string=) :test #'string=)))) diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 5334dfb04..0698b6a68 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -31,6 +31,8 @@ )package "BOOT" +$bootstrapDomains := false + -----------------------------NEW buildFunctor CODE----------------------------- NRTaddDeltaCode(kvec) == --NOTES: This function is called from buildFunctor to initially @@ -73,6 +75,8 @@ deltaTran(item,compItem) == newSig := [NRTassocIndex x or x for x in formalSig] [newSig,dcCode,op,:kindFlag] +$devaluateList := [] + NRTreplaceAllLocalReferences(form) == $devaluateList :local := [] NRTputInLocalReferences form diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot index fbd629af4..635c3bec0 100644 --- a/src/interp/postpar.boot +++ b/src/interp/postpar.boot @@ -35,6 +35,9 @@ -- Yet Another Parser Transformation File -- These functions are used by for SPAD code +$postStack := [] +$topOp := nil + postTransform y == $insidePostCategoryIfTrue : local := nil x:= y diff --git a/src/interp/scan.boot b/src/interp/scan.boot index a4e4c33b9..41e46f140 100644 --- a/src/interp/scan.boot +++ b/src/interp/scan.boot @@ -244,7 +244,6 @@ skip_whitespace(ln, n) == n := n + 1 n -DEFVAR($f) DEFVAR($floatok) DEFVAR($linepos) DEFVAR($ln) @@ -286,17 +285,16 @@ nextline(s)== if npNull s then false else - $f:= first s + f := first s $r:= rest s - $ln := rest $f - $linepos:=CAAR $f + $ln := rest(f) + $linepos := CAAR(f) $n := skip_whitespace($ln, 0) -- spaces at beginning $sz :=# $ln true lineoftoks(s)== - $f: local:=nil $r:local :=nil $ln:local :=nil $linepos:local:=nil diff --git a/src/interp/setq.lisp b/src/interp/setq.lisp index 28e96f909..2b7699b2e 100644 --- a/src/interp/setq.lisp +++ b/src/interp/setq.lisp @@ -33,14 +33,6 @@ (setq |$printTimeIfTrue| nil) -(setq |nullstream| '|nullstream|) -(setq |nonnullstream| '|nonnullstream|) -(setq *print-escape* nil) ;; so stringimage doesn't escape idents? - -;;; FIXME: do we need this? -#+(and :GCL :IEEE-FLOATING-POINT) - (setq system:*print-nans* T) - ;;; In case 'setvart.boot' does not work... (setq |$algebraOutputStream| (|mkOutputConsoleStream|)) @@ -49,57 +41,31 @@ (setq |$localVars| ()) ;checked by isType -;; For the browser, used for building local databases when a user compiles -;; their own code. -(SETQ |$newConstructorList| nil) -(SETQ |$newConlist| nil) -(SETQ |$createLocalLibDb| nil) - ;; These were originally in SPAD LISP -(setq |$interpOnly| nil) -(SETQ |$testingSystem| NIL) -(SETQ |$permitWhere| NIL) -(DEFPARAMETER |$bootStrapMode| NIL) ;; if true skip functor bodies -(SETQ |$bootstrapDomains| NIL) -(SETQ |$compileDontDefineFunctions| 'T) -(SETQ |$devaluateList| NIL) -(SETQ |$doNotCompressHashTableIfTrue| T) (SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT (SETQ |$maxSignatureLineNumber| 0) (SETQ |$functionLocations| NIL) -(SETQ |$functorLocalParameters| NIL) ; used in compSymbol -(SETQ |$insideCategoryPackageIfTrue| NIL) -(SETQ |$insideCompileBodyIfTrue| NIL) (SETQ |$globalExposureGroupAlist| NIL) (SETQ |$localExposureDataDefault| (VECTOR (LIST '|basic| '|categories|) NIL NIL)) (SETQ |$localExposureData| (VECTOR (LIST '|basic| '|categories|) NIL NIL)) (setq |$ReadingFile| NIL) +;; Used by Spad stream machinery (setq |$NonNullStream| "NonNullStream") (setq |$NullStream| "NullStream") (setq |$UninitializedStream| "UninitializedStream") -(setq |$domPvar| nil) -(defvar $dalymode nil "if true then leading paren implies lisp cmd") + (setq |$Newline| #\Newline) (SETQ $SPAD_ERRORS (VECTOR 0 0 0)) -(SETQ |$edit_file| NIL) (DEFPARAMETER |$InteractiveMode| T) (SETQ |$ruleSetsInitialized| NIL) -(SETQ |$returnNowhereFromGoGet| NIL) - -(SETQ |$insideCanCoerceFrom| NIL) - -(SETQ |$useCoerceOrCroak| T) - -(SETQ |$abbreviateJoin| NIL) - (SETQ |$InterpreterMacroAlist| '((|%i| . (|complex| 0 1)) (|%e| . (|exp| 1)) @@ -110,11 +76,13 @@ (|%minusInfinity| . (|minusInfinity|)))) ;; Common lisp control variables -;;(setq *load-verbose* nil) (setq *print-array* nil) (setq *print-pretty* t) (setq *print-circle* nil) - +(setq *print-escape* nil) ;; so stringimage doesn't escape idents +;;; FIXME: do we need this? +#+(and :GCL :IEEE-FLOATING-POINT) + (setq system:*print-nans* T) (SETQ |$systemCommands| '( ;; COMMAND USER LEVEL - )set userlevel @@ -195,23 +163,8 @@ |with| )) -;; following 2 variables are referenced by PREPARSE1 - -(defvar |$byConstructors| () "list of constructors to be compiled") -(defvar |$constructorsSeen| () "list of constructors found") - -;; These are for the output routines in OUT BOOT - -(SETQ $LINELENGTH 77) -(DEFPARAMETER $MARGIN 3) -(DEFCONST BLANK " ") -(DEFCONST UNDERBAR "_") -(SETQ |$fortranArrayStartingIndex| 0) - ;; These were originally in INIT LISP -(DEFPARAMETER |$functorForm| NIL) - (SETQ |$InitialCommandSynonymAlist| '( (|?| . "what commands") (|apropos| . "what things") @@ -245,7 +198,6 @@ (DEFPARAMETER |$ConstructorCache| (MAKE_HASHTABLE 'EQ)) (SETQ |$instantRecord| (MAKE_HASHTABLE 'EQ)) -(SETQ |$immediateDataSymbol| '|--immediateData--|) (SETQ |$useIntegerSubdomain| 'T) @@ -286,7 +238,7 @@ (SETQ |$Primitives| '(|Union| |Mapping| |Record| |Enumeration|)) (SETQ |$DomainsWithoutLisplibs| '( - CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) + CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Mode|)) (SETQ |$letAssoc| NIL) ;" used for trace of assignments in SPAD code -- see macro LETT" @@ -432,9 +384,6 @@ (SETQ |$NRTdeltaLength| 0) (SETQ |$NRTmonitorIfTrue| NIL) -(SETQ |$useConvertForCoercions| NIL) - - (setq credits '( "An alphabetical listing of contributors to AXIOM (to October, 2006):" diff --git a/src/interp/setvart.boot b/src/interp/setvart.boot index df8d27095..f0d5377b8 100644 --- a/src/interp/setvart.boot +++ b/src/interp/setvart.boot @@ -31,6 +31,9 @@ )package "BOOT" +$compileDontDefineFunctions := true +$fortranArrayStartingIndex := 0 + )if false This file contains functions to initialize the {\bf )set} command in the interpreter. diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot index 9838de16b..d8bb244da 100644 --- a/src/interp/showimp.boot +++ b/src/interp/showimp.boot @@ -32,8 +32,6 @@ )package "BOOT" -$returnNowhereFromGoGet := false - )if false Example usage: diff --git a/src/interp/trace.boot b/src/interp/trace.boot index 5a4a57d9a..99fdd3d02 100644 --- a/src/interp/trace.boot +++ b/src/interp/trace.boot @@ -36,6 +36,13 @@ -- This code supports the )trace system command and allows the -- tracing of LISP, BOOT and SPAD functions and interpreter maps. +$fromSpadTrace := false +$mapSubNameAlist := [] +$mathTrace := false +$mathTraceList := [] +$tracedSpadModemap := nil +$traceletFunctions := [] + DEFPARAMETER($traceNoisely, NIL) -- give trace and untrace messages DEFVAR($traceDomains, true) diff --git a/src/interp/util.lisp b/src/interp/util.lisp index a3da86957..939ddd190 100644 --- a/src/interp/util.lisp +++ b/src/interp/util.lisp @@ -38,86 +38,8 @@ A fifth group of related functions are some translated boot functions we need to define here so they work and are available at load time. |# -(in-package "BOOT") -(export '(|$spadroot| $directory-list reroot - make-absolute-filename |$defaultMsgDatabaseName|)) - -;;; Various lisps use different ``extensions'' on the filename to indicate -;;; that a file has been compiled. We set this variable correctly depending -;;; on the system we are using. -(defvar |$lisp_bin_filetype| - #+:GCL "o" - #+:cmu (c:backend-fasl-file-type c:*target-backend*) - #+:sbcl "fasl" - #+:clisp "fas" - #+:openmcl (subseq (namestring CCL:*.FASL-PATHNAME*) 1) - #+:ecl "fas" - #+:lispworks (pathname-type (compile-file-pathname "foo.lisp")) - #+:poplog "lsp" - #+:abcl "abcl" - ) - -;;; The relative directory list specifies a search path for files -;;; for the current directory structure. -(defvar $relative-directory-list - '("/share/msgs/" - "/share/spadhelp/" )) - -;;; The relative directory list specifies how to find the algebra -;;; directory from the current {\bf FRICAS} shell variable. -(defvar $relative-library-directory-list '("/algebra/")) - -;;; This is the system-wide list of directories to search. -;;; It is set up in the {\bf reroot} function. -(defvar $directory-list ()) - -;;; This is the system-wide search path for library files. -;;; It is set up in the {\bf reroot} function. -(defvar $library-directory-list ()) - -;;; Prefix a filename with the {\bf |$spadroot|} variable. -(defun make-absolute-filename (name) - (concatenate 'string |$spadroot| name)) - -#| -The reroot function is used to reset the important variables used by -the system. In particular, these variables are sensitive to the -{\bf FRICAS} shell variable. That variable is renamed internally to -be {\bf |$spadroot|}. The {\bf reroot} function will change the -system to use a new root directory and will have the same effect -as changing the {\bf FRICAS} shell variable and rerunning the system -from scratch. -|# -(defvar |$spadroot| "") -(defun reroot (dir) - (setq |$spadroot| dir) - (setq $directory-list - (mapcar #'make-absolute-filename $relative-directory-list)) - (setq $library-directory-list - (mapcar #'make-absolute-filename $relative-library-directory-list)) - (setq |$defaultMsgDatabaseName| - (make-absolute-filename "/share/msgs/s2-us.msgs")) - ) - -;;; Sets up the system to use the {\bf FRICAS} shell variable if we can -;;; otherwise use the parent directory of FRICASsys binary as fallback. -(defun initroot () - (let (spadroot) - (setq spadroot (or (|getEnv| "FRICAS") - (let ((bin-parent-dir - (concatenate 'string - (directory-namestring (car (|getCLArgs|))) - "/../"))) - (if (|fricas_probe_file| (concatenate 'string bin-parent-dir - "algebra/interp.daase")) - bin-parent-dir)) - (error "Environment variable FRICAS is not set!"))) - (setq spadroot (|fricas_probe_file| spadroot)) - (if spadroot - (reroot (trim-directory-name (namestring spadroot))) - (error "Environment variable FRICAS is not valid!"))) -) +(in-package "BOOT") ;;; Gnu Common Lisp (GCL) (at least 2.6.[78]) requires some changes ;;; to the default memory setup to run FriCAS efficiently. @@ -193,7 +115,7 @@ After this function is called the image is clean and can be saved. (push (list 'defparameter el (symbol-value el)) initforms))) (push `(interpsys-ecl-image-init) initforms) - (push `(fricas-restart) initforms) + (push `(|fricas_restart|) initforms) (setf initforms (reverse initforms)) (push `progn initforms) (setf FRICAS-LISP::*fricas-initial-lisp-forms* initforms) @@ -213,13 +135,13 @@ After this function is called the image is clean and can be saved. (interpsys-image-init nil) (format *standard-output* "spad = ~s~%" |$spadroot|) (force-output *standard-output*) - (format *standard-output* "before fricas-restart~%") + (format *standard-output* "before fricas_restart~%") (force-output *standard-output*) ) (defun interpsys-image-init (display_messages) (setf *package* (find-package "BOOT")) - (initroot) + (|initroot|) #+:GCL (init-memory-config :cons 500 :fixnum 200 :symbol 500 :package 8 :array 400 :string 500 :cfun 100 :cpages 1000 @@ -235,11 +157,6 @@ After this function is called the image is clean and can be saved. ;; the following are for conditional reading (setq |$opSysName| '"shell") -;;; moved from bookvol5 - -(defvar |$HiFiAccess| t "t means turn on history mechanism") - -(defvar |$reportUndo| nil "t means we report the steps undo takes") (defvar $openServerIfTrue t "t means try starting an open server") (defparameter $SpadServerName "/tmp/.d" "the name of the spad server socket") (defvar |$SpadServer| nil "t means Scratchpad acts as a remote server") @@ -249,14 +166,14 @@ After this function is called the image is clean and can be saved. (cond ((load "./exposed" :verbose nil :if-does-not-exist nil) '|done|) - ((load (make-absolute-filename "/algebra/exposed") + ((load (|make_absolute_filename| "/algebra/exposed") :verbose nil :if-does-not-exist nil) '|done|) (t '|failed|) )) (defvar *fricas-load-libspad* t) -(defun fricas-init () +(defun |fricas_init| () #+:GCL (init-memory-config :cons 500 :fixnum 200 :symbol 500 :package 8 :array 400 :string 500 :cfun 100 :cpages 3000 :rpages 1000 :hole 2000) @@ -264,12 +181,12 @@ After this function is called the image is clean and can be saved. #+:GCL (setq compiler::*suppress-compiler-warnings* t) #+:GCL (setq compiler::*suppress-compiler-notes* t) (in-package "BOOT") - (initroot) + (|initroot|) #+:poplog (setf POPLOG:*READ-PROMPT* "") ;; Turn off Poplog read prompts #+:GCL (system:gbc-time 0) #+(or :sbcl :clisp :openmcl :lispworks :cmu) (if *fricas-load-libspad* - (let ((spad-lib (make-absolute-filename "/lib/libspad.so"))) + (let ((spad-lib (|make_absolute_filename| "/lib/libspad.so"))) (format t "Checking for foreign routines~%") (format t "FRICAS=~S~%" |$spadroot|) (format t "spad-lib=~S~%" spad-lib) @@ -281,7 +198,7 @@ After this function is called the image is clean and can be saved. (|quiet_load_alien| spad-lib) #+(or :sbcl :openmcl) (fricas-lisp::init-gmp - (make-absolute-filename "/lib/gmp_wrap.so")) + (|make_absolute_filename| "/lib/gmp_wrap.so")) #+(and :clisp :ffi) (progn (eval `(FFI:DEFAULT-FOREIGN-LIBRARY ,spad-lib)) @@ -305,23 +222,7 @@ After this function is called the image is clean and can be saved. (|interpsys_restart|) ) -(DEFVAR |$trace_stream| *standard-output*) -(DEFVAR CUROUTSTREAM *standard-output*) - -(defun fricas-restart () - ;;; Need to reinitialize various streams because - ;;; CLISP closes them when dumping executable - (setf CUROUTSTREAM *standard-output*) - (setf |$trace_stream| *standard-output*) - (setq |$algebraOutputStream| (|mkOutputConsoleStream|)) - (setq |$fortranOutputStream| (|mkOutputConsoleStream|)) - (setq |$mathmlOutputStream| (|mkOutputConsoleStream|)) - (setq |$texmacsOutputStream| (|mkOutputConsoleStream|)) - (setq |$htmlOutputStream| (|mkOutputConsoleStream|)) - (setq |$openMathOutputStream| (|mkOutputConsoleStream|)) - (setq |$texOutputStream| (|mkOutputConsoleStream|)) - (setq |$formattedOutputStream| (|mkOutputConsoleStream|)) - (fricas-init) +(defun |fricas_restart2| () #+:poplog (|spad|) #-:poplog @@ -338,7 +239,7 @@ After this function is called the image is clean and can be saved. (setq |$SpadServer| nil) (setq $openServerIfTrue t) (FRICAS-LISP::save-core-restart save-file - (if do-restart #'boot::fricas-restart nil)) + (if do-restart #'boot::|fricas_restart| nil)) ) (defun |mkAutoLoad| (cname) diff --git a/src/lisp/Makefile.in b/src/lisp/Makefile.in index f75c6b851..73a7e63e5 100644 --- a/src/lisp/Makefile.in +++ b/src/lisp/Makefile.in @@ -125,15 +125,15 @@ do_it.ecl: fricas-lisp.lisp fricas-package.lisp fricas-config.lisp \ '(load "fricas-ecl.lisp")' \ '(load "fricas-lisp.lisp")' \ '(in-package "FRICAS-LISP")' \ - '(fricas_compile_file "fricas-package.lisp"' \ + '(|fricas_compile_file| "fricas-package.lisp"' \ ' "fricas-package.$(LISPOBJEXT)")' \ - '(fricas_compile_file "fricas-config.lisp"' \ + '(|fricas_compile_file| "fricas-config.lisp"' \ ' "fricas-config.$(LISPOBJEXT)")' \ - '(fricas_compile_file "fricas-ecl.lisp"' \ + '(|fricas_compile_file| "fricas-ecl.lisp"' \ ' "fricas-ecl.$(LISPOBJEXT)")' \ - '(fricas_compile_file "fricas-lisp.lisp"' \ + '(|fricas_compile_file| "fricas-lisp.lisp"' \ ' "fricas-lisp.$(LISPOBJEXT)")' \ - '(fricas_compile_file "primitives.lisp"' \ + '(|fricas_compile_file| "primitives.lisp"' \ ' "primitives.$(LISPOBJEXT)")' \ '(make-program "${OUT}/lisp$(EXEEXT)" nil)' | $(FRICAS_LISP) $(STAMP) $@ diff --git a/src/lisp/fricas-lisp.lisp b/src/lisp/fricas-lisp.lisp index 357aa063e..be51b6fb9 100644 --- a/src/lisp/fricas-lisp.lisp +++ b/src/lisp/fricas-lisp.lisp @@ -149,7 +149,7 @@ with this hack and will try to convince the GCL crowd to fix this. (CCL::save-application core-image :PREPEND-KERNEL t :application-class 'fricas-application) - (quit)) + (QUIT)) #+:lispworks (progn ; LispWorks by default loads a siteinit and an init file. @@ -209,7 +209,7 @@ with this hack and will try to convince the GCL crowd to fix this. (defun |exit_with_status| (s) (pop11::sysexit1 s)) -(defun quit() (|exit_with_status| 0)) +(defun QUIT() (|exit_with_status| 0)) ;;; ----------------------------------------------------------------- @@ -230,7 +230,7 @@ with this hack and will try to convince the GCL crowd to fix this. (c:build-program core-image :lisp-files (append *fricas-initial-lisp-objects* lisp-files) :ld-flags *fricas-extra-c-files*)) - (quit)) + (QUIT)) ;;; ----------------------------------------------------------------- ;;; For ECL assume :unix, when :netbsd or :darwin @@ -252,11 +252,11 @@ with this hack and will try to convince the GCL crowd to fix this. ;;; Chdir function #+:GCL -(defun chdir (dir) +(defun CHDIR (dir) (system::chdir dir)) #+:cmu -(defun chdir (dir) +(defun CHDIR (dir) (let ((tdir (probe-file dir))) (cond (tdir @@ -268,7 +268,7 @@ with this hack and will try to convince the GCL crowd to fix this. (eval-when (:execute :compile-toplevel :load-toplevel) (require :sb-posix)) #+:sbcl -(defun chdir (dir) +(defun CHDIR (dir) (let ((tdir (probe-file dir))) (cond (tdir @@ -277,19 +277,19 @@ with this hack and will try to convince the GCL crowd to fix this. (t nil)))) #+(and :clisp (or :unix :win32)) -(defun chdir (dir) +(defun CHDIR (dir) (ext::cd dir)) #+:openmcl -(defun chdir (dir) +(defun CHDIR (dir) (ccl::%chdir dir)) #+:ecl -(defun chdir (dir) - (SI:CHDIR (pad-directory-name dir) t)) +(defun CHDIR (dir) + (SI:CHDIR (|pad_directory_name| dir) t)) #+:lispworks -(defun chdir (dir) +(defun CHDIR (dir) (hcl:change-directory dir)) ;;; Environment access @@ -738,11 +738,11 @@ with this hack and will try to convince the GCL crowd to fix this. (fricas-foreign-call file_kind "directoryp" int (arg c-string)) - (fricas-foreign-call makedir "makedir" int + (fricas-foreign-call |makedir| "makedir" int (arg c-string)) ) -(defun trim-directory-name (name) +(defun |trim_directory_name| (name) #+(or :unix :win32) (if (char= (char name (1- (length name))) #\/) (subseq name 0 (1- (length name))) @@ -750,7 +750,7 @@ with this hack and will try to convince the GCL crowd to fix this. #-(or :unix :win32) (error "Not Unix and not Windows, what system it is?")) -(defun pad-directory-name (name) +(defun |pad_directory_name| (name) #+(or :unix :win32) (if (char= (char name (1- (length name))) #\/) name @@ -762,20 +762,20 @@ with this hack and will try to convince the GCL crowd to fix this. ;;; Make directory #+(or :abcl :cmu :lispworks :openmcl) -(defun makedir (fname) +(defun |makedir| (fname) (|run_program| "mkdir" (list fname))) #+:sbcl -(defun makedir (fname) +(defun |makedir| (fname) (sb-unix:unix-mkdir fname #o777)) #+:clisp -(defun makedir (fname) +(defun |makedir| (fname) ;; ext:make-dir was deprecated in clisp-2.44-2008-02-02 ;; and removed in clisp-2.49.90-2018-02-11 (let ((sym (or (find-symbol "MAKE-DIRECTORY" "EXT") (find-symbol "MAKE-DIR" "EXT")))) - (funcall sym (pad-directory-name (namestring fname))))) + (funcall sym (|pad_directory_name| (namestring fname))))) ;;; @@ -786,7 +786,7 @@ with this hack and will try to convince the GCL crowd to fix this. (find-symbol "UNIX-FILE-KIND" :sb-unix)))) `(,file-kind-fun ,x))) -(defun file-kind (filename) +(defun |file_kind| (filename) #+(or :GCL :ecl) (file_kind filename) #+:cmu (case (unix:unix-file-kind filename) @@ -803,8 +803,8 @@ with this hack and will try to convince the GCL crowd to fix this. (if (probe-file filename) 0 -1)) - #+:clisp (let* ((fname (trim-directory-name (namestring filename))) - (dname (pad-directory-name fname))) + #+:clisp (let* ((fname (|trim_directory_name| (namestring filename))) + (dname (|pad_directory_name| fname))) (if (ignore-errors (truename dname)) 1 (if (ignore-errors (truename fname)) @@ -821,29 +821,29 @@ with this hack and will try to convince the GCL crowd to fix this. ) #+:cmu -(defun get-current-directory () +(defun |get_current_directory| () (multiple-value-bind (win dir) (unix::unix-current-directory) (declare (ignore win)) dir)) #+(or :ecl :GCL :sbcl :clisp :openmcl :abcl) -(defun get-current-directory () - (trim-directory-name (namestring (truename "")))) +(defun |get_current_directory| () + (|trim_directory_name| (namestring (truename "")))) #+:poplog -(defun get-current-directory () +(defun |get_current_directory| () (let ((name (namestring (truename ".")))) - (trim-directory-name (subseq name 0 (1- (length name)))))) + (|trim_directory_name| (subseq name 0 (1- (length name)))))) #+lispworks -(defun get-current-directory () +(defun |get_current_directory| () (let ((directory (namestring (system:current-directory)))) - (trim-directory-name directory))) + (|trim_directory_name| directory))) (defun |fricas_probe_file| (file) -#+:GCL (let* ((fk (file-kind (namestring file))) - (fname (trim-directory-name (namestring file))) - (dname (pad-directory-name fname))) +#+:GCL (let* ((fk (file_kind (namestring file))) + (fname (|trim_directory_name| (namestring file))) + (dname (|pad_directory_name| fname))) (cond ((equal fk 1) (truename dname)) @@ -853,8 +853,8 @@ with this hack and will try to convince the GCL crowd to fix this. #+:cmu (if (unix:unix-file-kind file) (truename file)) #+:sbcl (if (sbcl-file-kind file) (truename file)) #+(or :abcl :ecl :lispworks :openmcl :poplog) (probe-file file) -#+:clisp(let* ((fname (trim-directory-name (namestring file))) - (dname (pad-directory-name fname))) +#+:clisp(let* ((fname (|trim_directory_name| (namestring file))) + (dname (|pad_directory_name| fname))) (or (ignore-errors (truename dname)) (ignore-errors (truename fname)))) ) @@ -866,28 +866,28 @@ with this hack and will try to convince the GCL crowd to fix this. (eq (car (pathname-directory name)) :absolute)) ns - (concatenate 'string (get-current-directory) "/" ns)))) + (concatenate 'string (|get_current_directory|) "/" ns)))) #+:cmu (defun relative-to-absolute (name) (unix::unix-maybe-prepend-current-directory name)) ;;; Saner version of compile-file #+:ecl -(defun fricas_compile_file (f output-file) +(defun |fricas_compile_file| (f output-file) (compile-file f :output-file (relative-to-absolute output-file) :system-p t)) #+:poplog -(defun fricas_compile_file (f output-file) +(defun |fricas_compile_file| (f output-file) (|run_program| "cp" (list f output-file))) #-(or :ecl :poplog) -(defun fricas_compile_file (f output-file) +(defun |fricas_compile_file| (f output-file) (compile-file f :output-file (relative-to-absolute output-file))) -(defun fricas_compile_fasl (f output-file) +(defun |fricas_compile_fasl| (f output-file) #-:ecl - (fricas_compile_file f output-file) + (|fricas_compile_file| f output-file) #+:ecl (compile-file f :output-file (relative-to-absolute output-file)) ) @@ -1035,6 +1035,21 @@ with this hack and will try to convince the GCL crowd to fix this. (in-package "BOOT") +;;; Various lisps use different ``extensions'' on the filename to indicate +;;; that a file has been compiled. We set this variable correctly depending +;;; on the system we are using. +(defvar |$lisp_bin_filetype| + #+:GCL "o" + #+:cmu (c:backend-fasl-file-type c:*target-backend*) + #+:sbcl "fasl" + #+:clisp "fas" + #+:openmcl (subseq (namestring CCL:*.FASL-PATHNAME*) 1) + #+:ecl "fas" + #+:lispworks (pathname-type (compile-file-pathname "foo.lisp")) + #+:poplog "lsp" + #+:abcl "abcl" +) + ;;; Macros used in Boot code (defmacro IFCAR (x) diff --git a/src/lisp/fricas-package.lisp b/src/lisp/fricas-package.lisp index ca182cd81..fdc021171 100644 --- a/src/lisp/fricas-package.lisp +++ b/src/lisp/fricas-package.lisp @@ -41,9 +41,10 @@ (mapcar (lambda (#3=#:x) (export (list #3#))) #1#) ) -(export '(quit chdir |getEnv| |getCLArgs| |load_quietly| get-current-directory - trim-directory-name pad-directory-name - file-kind makedir fricas_compile_file fricas_compile_fasl +(export '(QUIT CHDIR |getEnv| |getCLArgs| |load_quietly| + |get_current_directory| + |trim_directory_name| |pad_directory_name| + |file_kind| |makedir| |fricas_compile_file| |fricas_compile_fasl| |fricas_probe_file| |run_program| |run_shell_command| DEFCONST |exit_with_status| MEMQ |quiet_load_alien| |handle_input_file| |handle_output_file| |maybe_delete_file| diff --git a/src/scripts/build_helper b/src/scripts/build_helper index 4560a640c..5a8059834 100755 --- a/src/scripts/build_helper +++ b/src/scripts/build_helper @@ -13,7 +13,7 @@ compile_lisp() { "$image" <