From fde9260a842114ae27a99f7de23c9a46b79eccf4 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 20 Sep 2008 17:54:46 +0000 Subject: * include/cfuns.h (oa_dirname): Declare. * lib/cfuns-c.c (openaxiom_is_path_separator): New. (oa_dirname): Define. (writeablep): Use it. * algebra/fname.spad.pamphlet (writable?$FileName): Tidy. --- src/ChangeLog | 8 +++++ src/algebra/fname.spad.pamphlet | 4 +-- src/include/cfuns.h | 1 + src/interp/br-con.boot | 4 +-- src/interp/c-util.boot | 17 +++++++++-- src/interp/category.boot | 7 +++++ src/interp/compiler.boot | 4 +-- src/interp/define.boot | 7 +++++ src/interp/g-error.boot | 4 +-- src/interp/g-util.boot | 2 +- src/interp/ht-util.boot | 4 +-- src/interp/i-toplev.boot | 6 ---- src/interp/i-util.boot | 7 +++++ src/interp/int-top.boot | 6 ++-- src/interp/osyscmd.boot | 2 +- src/interp/record.boot | 2 +- src/interp/server.boot | 14 ++++----- src/interp/spad.lisp | 11 ------- src/interp/sys-constants.boot | 3 ++ src/interp/sys-driver.boot | 4 +-- src/interp/wi1.boot | 6 ++-- src/lib/cfuns-c.c | 65 ++++++++++++++++++++++++++++++++++------- 22 files changed, 129 insertions(+), 59 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index 930b62b5..7c0491fc 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,11 @@ +2008-09-20 Gabriel Dos Reis + + * include/cfuns.h (oa_dirname): Declare. + * lib/cfuns-c.c (openaxiom_is_path_separator): New. + (oa_dirname): Define. + (writeablep): Use it. + * algebra/fname.spad.pamphlet (writable?$FileName): Tidy. + 2008-09-19 Gabriel Dos Reis * interp/g-util.boot (getTypeOfSyntax): Infer more syntax domains. diff --git a/src/algebra/fname.spad.pamphlet b/src/algebra/fname.spad.pamphlet index bfc9dc11..e9c558fb 100644 --- a/src/algebra/fname.spad.pamphlet +++ b/src/algebra/fname.spad.pamphlet @@ -99,8 +99,8 @@ FileName(): FileNameCategory == add extension(f:%): String == fnameType(f)$Lisp exists? f == existingFile?(f::String)$Lisp - readable? f == readablep(f::String)$Lisp : Integer = 1 - writable? f == writeablep(f::String)$Lisp : Integer = 1 + readable? f == readablep(f::String)$Lisp = 1@SingleInteger + writable? f == writeablep(f::String)$Lisp > 0@SingleInteger new(d,pref,e) == fnameNew(d,pref,e)$Lisp diff --git a/src/include/cfuns.h b/src/include/cfuns.h index 3ad83197..225ce6de 100644 --- a/src/include/cfuns.h +++ b/src/include/cfuns.h @@ -53,6 +53,7 @@ OPENAXIOM_EXPORT int oa_system(const char*); OPENAXIOM_EXPORT char* oa_getenv(const char*); OPENAXIOM_EXPORT char* oa_getcwd(void); OPENAXIOM_EXPORT int oa_access_file_for_read(const char*); +OPENAXIOM_EXPORT char* oa_dirname(const char*); OPENAXIOM_EXPORT const char* oa_get_tmpdir(void); OPENAXIOM_EXPORT double plus_infinity(void); OPENAXIOM_EXPORT double minus_infinity(void); diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index 117ed0a3..136bd104 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -649,7 +649,7 @@ kDomainName(htPage,kind,name,nargs) == argTailPart := "STRCONC"/["STRCONC"/ ['",",:x] for x in KDR args] "STRCONC"/['"(",:first args,argTailPart,'")"] - typeForm := CATCH('SPAD__READER, unabbrev mkConform(kind,name,argString)) or + typeForm := CATCH($SpadReaderTag, unabbrev mkConform(kind,name,argString)) or ['error,'invalidType,STRCONC(name,argString)] null (evaluatedTypeForm := kisValidType typeForm) => ['error,'invalidType,STRCONC(name,argString)] @@ -678,7 +678,7 @@ topLevelInterpEval x == kisValidType typeForm == $ProcessInteractiveValue: fluid := true $noEvalTypeMsg: fluid := true - CATCH('SPAD__READER, processInteractive(typeForm,nil)) + CATCH($SpadReaderTag, processInteractive(typeForm,nil)) is [[h,:.],:t] and member(h,'(Domain SubDomain)) => kCheckArgumentNumbers t and t false diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 3735a815..47ff18b1 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -35,6 +35,19 @@ import g_-util namespace BOOT +--% +++ if true continue compiling after errors +$scanIfTrue := false + + ++++ If non nil, holds compiled value of 'Rep' of the current domain. +$Representation := nil + + +$formalArgList := [] + +--% + ++ If using old `Rep' definition semantics, return `$' when m is `Rep'. ++ Otherwise, return `m'. dollarIfRepHack m == @@ -129,10 +142,10 @@ displayComp level == $bright:= " << " $dim:= " >> " if $insideCapsuleFunctionIfTrue=true then - sayBrightly ['"error in function",'%b,$op,'%d,'%l] + sayBrightly ['"error in function",:bright $op,'%l] --mathprint removeZeroOne mkErrorExpr level pp removeZeroOne mkErrorExpr level - sayBrightly ['"****** level",'%b,level,'%d,'" ******"] + sayBrightly ['"****** level",:bright level,'" ******"] [$x,$m,$f,$exitModeStack]:= ELEM($s,level) SAY("$x:= ",$x) SAY("$m:= ",$m) diff --git a/src/interp/category.boot b/src/interp/category.boot index 9568c605..c9f56468 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -35,6 +35,13 @@ import g_-util namespace BOOT +--% + +++ List of global attributes. +$Attributes := [] + +--% + ++ Returns true if `a' is a category (runtime) object. isCategory: %Thing -> %Boolean isCategory a == diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index cb9f8110..121924bd 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1687,7 +1687,7 @@ compileSpad2Cmd args == translateOldToNew := nil - $scanIfTrue : local := nil + $scanIfTrue : local := false $compileOnlyCertainItems : local := nil $f : local := nil -- compiler $m : local := nil -- variables @@ -1774,7 +1774,7 @@ convertSpadToAsFile path == $outStream :local := MAKE_-OUTSTREAM newName markSay('"#include _"axiom.as_"") markTerpri() - CATCH("SPAD__READER",compiler [path]) + CATCH($SpadReaderTag,compiler [path]) SHUT $outStream mkCheck() 'done diff --git a/src/interp/define.boot b/src/interp/define.boot index 2d1a94e4..88ef628d 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -37,6 +37,8 @@ import cattable import category namespace BOOT +--% + NRTPARSE := false $newCompCompare := false @@ -53,6 +55,11 @@ $suffix := nil -- ??? turns off buggy code $NRTopt := false + +$doNotCompileJustPrint := false + +--% + ++ List of operations defined in a given capsule ++ Each item on this list is of the form ++ (op sig pred) diff --git a/src/interp/g-error.boot b/src/interp/g-error.boot index 2d7747d5..6123c2ff 100644 --- a/src/interp/g-error.boot +++ b/src/interp/g-error.boot @@ -131,7 +131,7 @@ handleLispBreakLoop($BreakMode) == BREAK() sayBrightly '" Processing will continue where it was interrupted." - THROW('SPAD__READER, nil) + THROW($SpadReaderTag, nil) $BreakMode = 'resume => returnToReader() returnToTopLevel() @@ -146,7 +146,7 @@ returnToTopLevel() == returnToReader() == ^$ReadingFile => returnToTopLevel() sayBrightly ['" Continuing to read the file...", '%l] - THROW('SPAD__READER, nil) + THROW($SpadReaderTag, nil) sayErrorly(errorLabel, msg) == $saturn => saturnSayErrorly(errorLabel, msg) diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 6786fa83..c732d9b4 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -464,7 +464,7 @@ mergeSort(f,g,p,n) == spadThrow() == if $interpOnly and $mapName then putHist($mapName,'localModemap, nil, $e) - THROW("SPAD__READER",nil) + THROW($SpadReaderTag,nil) spadThrowBrightly x == sayBrightly x diff --git a/src/interp/ht-util.boot b/src/interp/ht-util.boot index 9f32e448..fe18f0e5 100644 --- a/src/interp/ht-util.boot +++ b/src/interp/ht-util.boot @@ -473,7 +473,7 @@ executeInterpreterCommand command == PRINC command TERPRI() ncSetCurrentLine(command) - CATCH('SPAD__READER, parseAndInterpret command) + CATCH($SpadReaderTag, parseAndInterpret command) PRINC MKPROMPT() FINISH_-OUTPUT() @@ -512,7 +512,7 @@ checkCondition(s1, string, condList) == val = '"Syntax Error " => '"Error: Syntax Error " condErrorMsg pattern [type, : data] := val - newType := CATCH('SPAD__READER, resolveTM(type, pattern)) + newType := CATCH($SpadReaderTag, resolveTM(type, pattern)) null newType => condErrorMsg pattern coerceInt(val, newType) diff --git a/src/interp/i-toplev.boot b/src/interp/i-toplev.boot index 378a1399..6af0a9e7 100644 --- a/src/interp/i-toplev.boot +++ b/src/interp/i-toplev.boot @@ -40,12 +40,6 @@ namespace BOOT $intCoerceFailure == "coerceFailure" -$intTopLevel == - "top__level" - -$intSpadReader == - "SPAD__READER" - $intRestart == "restart" diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot index 0377cef7..5fe07fb2 100644 --- a/src/interp/i-util.boot +++ b/src/interp/i-util.boot @@ -33,6 +33,13 @@ import g_-util namespace BOOT +module i_-util + +--% + +$intTopLevel == + "top__level" + --% The function for making prompts spadPrompt() == diff --git a/src/interp/int-top.boot b/src/interp/int-top.boot index 5c4664bc..9e5b1063 100644 --- a/src/interp/int-top.boot +++ b/src/interp/int-top.boot @@ -41,7 +41,7 @@ ncParseAndInterpretString s == processInteractive(packageTran parseFromString s, nil) ncParseFromString s == - zeroOneTran packageTran CATCH("SPAD__READER", parseFromString s) + zeroOneTran packageTran CATCH($SpadReaderTag, parseFromString s) ncINTERPFILE(file, echo) == savedEcho := $EchoLines @@ -85,7 +85,7 @@ runspad() == while mode='restart repeat resetStackLimits() CATCH($quitTag, CATCH('coerceFailure, - mode:=CATCH('top__level, ncTopLevel()))) + mode:=CATCH($intTopLevel, ncTopLevel()))) ncTopLevel() == -- Top-level read-parse-eval-print loop for the interpreter. Uses @@ -228,7 +228,7 @@ intloopSpadProcess(stepNo,lines,ptree,interactive?)== ncPutQ(cc, 'lines, lines) $ncMsgList := nil result := CatchAsCan(flung, Catch("SpadCompileItem", - CATCH($intCoerceFailure, CATCH($intSpadReader, + CATCH($intCoerceFailure, CATCH($SpadReaderTag, interp(cc, ptree, interactive?))))) where interp(cc, ptree, interactive?) == diff --git a/src/interp/osyscmd.boot b/src/interp/osyscmd.boot index 68a0eac9..264bc3e2 100644 --- a/src/interp/osyscmd.boot +++ b/src/interp/osyscmd.boot @@ -38,7 +38,7 @@ namespace BOOT InterpExecuteSpadSystemCommand string == CATCH($intCoerceFailure, - CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) + CATCH($SpadReaderTag, ExecuteInterpSystemCommand string) ) ExecuteInterpSystemCommand string == string := intProcessSynonyms(string) diff --git a/src/interp/record.boot b/src/interp/record.boot index cdd02714..74591e14 100644 --- a/src/interp/record.boot +++ b/src/interp/record.boot @@ -88,7 +88,7 @@ inputFile2RecordFile(pathname,:option) == $currentLine: local := nil if isExistingFile opathname then DELETE_-FILE opathname $testStream := MAKE_-OUTSTREAM opathname - CATCH('SPAD__READER,_/READ(pathname,nil)) + CATCH($SpadReaderTag,_/READ(pathname,nil)) --for trailing system commands if not null $currentLine then recordAndPrintTest '(ForSystemCommands) SHUT $testStream diff --git a/src/interp/server.boot b/src/interp/server.boot index 5f7652d8..57a706a3 100644 --- a/src/interp/server.boot +++ b/src/interp/server.boot @@ -88,7 +88,7 @@ serverReadLine(stream) == action = $SpadCommand => $NeedToSignalSessionManager := true stringBuf := sockGetString $MenuServer - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + CATCH('coerceFailure,CATCH($intTopLevel, CATCH($SpadReaderTag, parseAndInterpret stringBuf))) PRINC MKPROMPT() FINISH_-OUTPUT() @@ -114,7 +114,7 @@ oldParseAndInterpret str == executeQuietCommand() == $QuietCommand: fluid := true stringBuf := sockGetString $MenuServer - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + CATCH('coerceFailure,CATCH($intTopLevel, CATCH($SpadReaderTag, parseAndInterpret stringBuf))) -- Includued for compatability with old-parser systems @@ -126,7 +126,7 @@ serverLoop() == $Prompt := NIL action := serverSwitch() action = $CallInterp => - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + CATCH('coerceFailure,CATCH($intTopLevel, CATCH($SpadReaderTag, parseAndInterpret read_-line($InputStream) ))) PRINC MKPROMPT() FINISH_-OUTPUT() @@ -153,7 +153,7 @@ serverLoop() == executeQuietCommand() action = $SpadCommand => stringBuf := sockGetString $MenuServer - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + CATCH('coerceFailure,CATCH($intTopLevel, CATCH($SpadReaderTag, parseAndInterpret stringBuf))) PRINC MKPROMPT() FINISH_-OUTPUT() @@ -173,21 +173,21 @@ parseAndEvalToString str == $collectOutput:local := true $outputLines: local := nil $IOindex: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v := CATCH($SpadReaderTag, CATCH($intTopLevel, parseAndEvalStr str)) v = 'restart => ['"error"] NREVERSE $outputLines parseAndEvalToStringForHypertex str == $collectOutput:local := true $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v := CATCH($SpadReaderTag, CATCH($intTopLevel, parseAndEvalStr str)) v = 'restart => ['"error"] NREVERSE $outputLines parseAndEvalToStringEqNum str == $collectOutput:local := true $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v := CATCH($SpadReaderTag, CATCH($intTopLevel, parseAndEvalStr str)) v = 'restart => ['"error"] NREVERSE $outputLines diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp index 914bb45d..e6d174dc 100644 --- a/src/interp/spad.lisp +++ b/src/interp/spad.lisp @@ -44,31 +44,20 @@ (defconstant |$Newline| #\Newline) (defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") -(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") (defvar |$reportInstantiations| nil) (defvar |$reportEachInstantiation| nil) (defvar |$reportCounts| nil) -(defvar |$CategoryDefaults| nil) (defvar |$compForModeIfTrue| nil "checked in compSymbol") (defvar |$functorForm| nil "checked in addModemap0") -(defvar |$formalArgList| nil "checked in compSymbol") -(defvar |$newCompAtTopLevel| nil "if t uses new compiler") -(defvar |$doNotCompileJustPrint| nil "switch for compile") (defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") -(defvar |$scanIfTrue| nil "if t continue compiling after errors") -(defvar |$Representation| nil "checked in compNoStacking") (defvar |$definition| nil "checked in DomainSubstitutionFunction") -(defvar |$Attributes| nil "global attribute list used in JoinInner") (defvar |$getPutTrace| nil) (defvar |$specialCaseKeyList| nil "checked in optCall") (defvar |$formulaFormat| nil "if true produce script formula output") (defvar |$texFormat| nil "if true produce tex output") (defvar |$fortranFormat| nil "if true produce fortran output") (defvar |$algebraFormat| t "produce 2-d algebra output") -(defvar |$kernelWarn| NIL "") -(defvar |$kernelProtect| NIL "") (defvar |$HiFiAccess| nil "if true maintain history file") -(defvar |$mapReturnTypes| nil) (defvar |boot-NewKEY| NIL) diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index 4bf36c9e..98544eb2 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -712,3 +712,6 @@ $QuerySpad == 12 $NonSmanSession == 13 $KillLispSystem == 14 + +$SpadReaderTag == + "SPAD__READER" diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot index b9b0739c..4c98c8e2 100644 --- a/src/interp/sys-driver.boot +++ b/src/interp/sys-driver.boot @@ -252,7 +252,7 @@ executeSpadScript(progname,options,file) == $ProcessInteractiveValue := true $PrintCompilerMessageIfTrue := $verbose CATCH($intCoerceFailure, - CATCH($intSpadReader,read [file])) + CATCH($SpadReaderTag,read [file])) coreQuit (errorCount()> 0 => 1; 0) associateRequestWithFileType(Option '"script", '"input", @@ -269,7 +269,7 @@ compileSpadLibrary(progname,options,file) == $PrintCompilerMessageIfTrue := $verbose CATCH($intTopLevel, CATCH("SpadCompileItem", - CATCH($intSpadReader,compiler [file]))) + CATCH($SpadReaderTag,compiler [file]))) coreQuit (errorCount()> 0 => 1; 0) associateRequestWithFileType(Option '"compile", '"spad", diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot index 7f5592dd..bb120ab5 100644 --- a/src/interp/wi1.boot +++ b/src/interp/wi1.boot @@ -53,7 +53,7 @@ tr fn == markSay '"#pile" markSay('"#include _"axiom.as_"") markTerpri() - CATCH("SPAD__READER",compiler [INTERN sfn]) + CATCH($SpadReaderTag,compiler [INTERN sfn]) SHUT $outStream ppFull x == @@ -146,8 +146,6 @@ compDefineLisplib(df,m,e,prefix,fal,fn) == --will eventually become the "constructorCategory" property in lisplib --set in compDefineCategory if category, otherwise in finalizeLisplib libName := getConstructorAbbreviation op - -- $incrementalLisplibFlag seems never to be set so next line not used - -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) BOUNDP '$compileDocumentation and $compileDocumentation => compileDocumentation libName sayMSG ['" initializing ",$spadLibFT,:bright libName, @@ -171,7 +169,7 @@ compTopLevel(x,m,e) == $resolveTimeSum: local := 0 $packagesUsed: local := [] -- The next line allows the new compiler to be tested interactively. - compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak + compFun := 'compOrCroak if x is ["where",:.] then x := markWhereTran x def := x is ["where",a,:.] => a diff --git a/src/lib/cfuns-c.c b/src/lib/cfuns-c.c index 4fbf48de..47a1f8c4 100644 --- a/src/lib/cfuns-c.c +++ b/src/lib/cfuns-c.c @@ -94,6 +94,51 @@ addtopath(char *dir) return putenv(newpath); } + + +/* Returns 1 if `c' designates a path separator, 0 otherwise. */ +static inline int +openaxiom_is_path_separator(char c) +{ +#ifdef __WIN32__ + return c == '\\' || c == '/'; +#else + return c == '/'; +#endif +} + +/* + Returns a the dirname of `path'. If `path' has no separator, then + returns ".". The returned value if malloc-allocated. */ + +OPENAXIOM_EXPORT char* +oa_dirname(const char* path) +{ + const int n = strlen(path); + char* mark = mark + n; + + if (n == 0) + return strdup("."); + else if (n == 1 && openaxiom_is_path_separator(*path)) + return strdup("/"); + + /* For "/banana/space/", we want "/banana". */ + if (openaxiom_is_path_separator(*--mark)) + --mark; + while (path < mark && !openaxiom_is_path_separator(*mark)) + --mark; + + if (path == mark) + return strdup(openaxiom_is_path_separator(*path) ? "/" : "."); + else { + const int l = mark - path; + char* dir = (char*) malloc(l + 1); + memcpy(dir, path, l); + dir[l] = '\0'; + return dir; + } +} + /* * Test whether the path is the name of a directory. Returns 1 if so, 0 if * not, -1 if it doesn't exist. @@ -167,15 +212,15 @@ axiom_has_write_access(const struct stat* file_info) return 1; if (effetive_uid == file_info->st_uid) - return file_info->st_mode & S_IWUSR; + return (file_info->st_mode & S_IWUSR) ? 1 : 0; #ifdef S_IWGRP if (getegid() == file_info->st_gid) - return file_info->st_mode & S_IWGRP; + return (file_info->st_mode & S_IWGRP) ? 1 : 0; #endif #ifdef S_IWOTH - return file_info->st_mode & S_IWOTH; + return (file_info->st_mode & S_IWOTH) ? 1 : 0; #else return 0; #endif @@ -193,18 +238,16 @@ OPENAXIOM_EXPORT int writeablep(char *path) { struct stat buf; - char newpath[100]; int code; code = stat(path, &buf); if (code == -1) { - /** The file does not exist, so check to see - if the directory is writable *****/ - if (make_path_from_file(newpath, path) == -1 - || stat(newpath, &buf) == -1) - return -1; - - return 2 * axiom_has_write_access(&buf); + /* The file does not exist, so check to see if the directory + is writable. */ + char* dir = oa_dirname(path); + code = stat(dir, &buf); + free(dir); + return (code == 0) && axiom_has_write_access(&buf) ? 2 : -1; } return axiom_has_write_access(&buf); -- cgit v1.2.3