aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog9
-rw-r--r--src/boot/strap/ast.clisp4
-rw-r--r--src/boot/strap/parser.clisp4
-rw-r--r--src/boot/strap/tokens.clisp22
-rw-r--r--src/boot/strap/translator.clisp88
-rw-r--r--src/boot/strap/utility.clisp2
-rw-r--r--src/boot/tokens.boot9
-rw-r--r--src/interp/nlib.lisp37
-rw-r--r--src/interp/pathname.boot2
-rw-r--r--src/interp/sys-utility.boot18
-rw-r--r--src/interp/vmlisp.lisp6
11 files changed, 101 insertions, 100 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index e36e3649..43ce7ad2 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,14 @@
2013-05-26 Gabriel Dos Reis <gdr@integrable-solutions.net>
+ * interp/sys-utility.boot (makeFilename): Move from nlib.lisp.
+ * interp/nlib.lisp (MAKE-FILENAME): Move to sys-utility.boot.
+ Adjust callers.
+ * boot/tokens.boot: Add new builtins: filePath, filePath?,
+ filePathDirectory, filePathName, filePathString, filePathType,
+ makeFilePath.
+
+2013-05-26 Gabriel Dos Reis <gdr@integrable-solutions.net>
+
* interp/nlib.lisp (ADDOPTIONS): Move to sys-utility.boot.
* interp/sys-utility.boot (addCompilerOption): Rename from ADDOPTIONS.
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index fdd34743..94f3cce2 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -3739,8 +3739,11 @@
|call|))))
(LIST (LIST 'DEFUN |op| |parms| |call|)))))
+(DEFPARAMETER |$ffs| NIL)
+
(DEFUN |genImportDeclaration| (|op| |sig|)
(LET* (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|)
+ (DECLARE (SPECIAL |$ffs|))
(COND
((NOT
(AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|)
@@ -3765,6 +3768,7 @@
(PROGN (SETQ |s| (CAR |ISTMP#2|)) T)))))))
(|coreError| "invalid function type"))
(T (COND ((AND |s| (SYMBOLP |s|)) (SETQ |s| (LIST |s|))))
+ (SETQ |$ffs| (CONS |op| |$ffs|))
(COND
((|%hasFeature| :GCL) (|genGCLnativeTranslation| |op| |s| |t| |op'|))
((|%hasFeature| :SBCL) (|genSBCLnativeTranslation| |op| |s| |t| |op'|))
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 985611d3..b6c95484 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
(COND (|done| (RETURN NIL))
(T
(SETQ |found|
- (LET ((#1=#:G720
+ (LET ((#1=#:G725
(CATCH :OPEN-AXIOM-CATCH-POINT
(APPLY |f| |ps| NIL))))
(COND
@@ -1371,7 +1371,7 @@
(SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|)))
(SETQ |varno| (|parserGensymSequenceNumber| |ps|))
(UNWIND-PROTECT
- (LET ((#1=#:G721
+ (LET ((#1=#:G726
(CATCH :OPEN-AXIOM-CATCH-POINT
(PROGN
(SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 4c088f8d..b606644b 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -84,10 +84,10 @@
(LET* (|s|)
(COND
((SETQ |s|
- (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
(LET ((|bfVar#1| NIL))
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
+ (MULTIPLE-VALUE-BIND (#2=#:G725 |k| |v|)
(#1#)
(COND ((NOT #2#) (RETURN |bfVar#1|))
(T
@@ -138,9 +138,9 @@
(COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
(SETQ |i| (+ |i| 1))))
|a|))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
+ (MULTIPLE-VALUE-BIND (#2=#:G727 |s| #:G728)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
|d|)))
@@ -154,9 +154,9 @@
(LET ((|i| 0))
(LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
(SETQ |i| (+ |i| 1))))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G729 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
+ (MULTIPLE-VALUE-BIND (#2=#:G730 |k| #:G731)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
(T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
@@ -216,13 +216,19 @@
(LIST '|copyString| 'COPY-SEQ) (LIST '|copyVector| 'COPY-SEQ)
(LIST '|croak| 'CROAK) (LIST '|digit?| 'DIGIT-CHAR-P)
(LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|fifth| 'FIFTH)
- (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP)
+ (LIST '|first| 'CAR) (LIST '|filePath| 'PATHNAME)
+ (LIST '|filePath?| 'PATHNAMEP)
+ (LIST '|filePathDirectory| 'PATHNAME-DIRECTORY)
+ (LIST '|filePathName| 'PATHNAME-NAME)
+ (LIST '|filePathString| 'NAMESTRING)
+ (LIST '|filePathType| 'PATHNAME-TYPE) (LIST '|float?| 'FLOATP)
(LIST '|flushOutput| 'FORCE-OUTPUT) (LIST '|fourth| 'CADDDR)
(LIST '|freshLine| 'FRESH-LINE) (LIST '|function?| 'FUNCTIONP)
(LIST '|functionSymbol?| 'FBOUNDP) (LIST '|gensym| 'GENSYM)
(LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP)
(LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL)
- (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN)
+ (LIST '|lowerCase?| 'LOWER-CASE-P)
+ (LIST '|makeFilePath| 'MAKE-PATHNAME) (LIST '|makeSymbol| 'INTERN)
(LIST '|mkpf| 'MKPF) (LIST '|newVector| 'MAKE-ARRAY)
(LIST '|nil| NIL) (LIST '|not| 'NOT) (LIST '|null| 'NULL)
(LIST '|odd?| 'ODDP) (LIST '|or| 'OR) (LIST '|otherwise| 'T)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index c681da73..4cc7a1bb 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -26,63 +26,46 @@
(PROGN (|prettyPrint| |x| |st|) (TERPRI |st|)))
(DEFUN |genModuleFinalization| (|stream|)
- (LET* (|init|)
- (DECLARE (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|))
- (COND
- ((|%hasFeature| :CLISP)
- (COND ((NULL |$foreignsDefsForCLisp|) NIL)
- ((NULL |$currentModuleName|)
- (|coreError| "current module has no name"))
- (T
- (SETQ |init|
- (LIST 'EVAL-WHEN (LIST :LOAD-TOPLEVEL :EXECUTE)
- (CONS 'PROGN
- (CONS
- (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND)
- (|quote|
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1|
- |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |d| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #1=(CONS (CADR |d|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3|
- (CDR |bfVar#3|))))
- (SETQ |bfVar#1|
- (CDR |bfVar#1|))))))
- (LET ((|bfVar#5| NIL)
- (|bfVar#6| NIL)
- (|bfVar#4| |$foreignsDefsForCLisp|)
+ (LET* (|init| |setFFS|)
+ (DECLARE (SPECIAL |$foreignsDefsForCLisp| |$currentModuleName| |$ffs|))
+ (COND ((NULL |$ffs|) NIL)
+ ((NULL |$currentModuleName|)
+ (|coreError| "current module has no name"))
+ (T
+ (SETQ |setFFS|
+ (LIST 'SETQ '|$dynamicForeignFunctions|
+ (LIST '|append!| (|quote| |$ffs|)
+ '|$dynamicForeignFunctions|)))
+ (|reallyPrettyPrint| (|atLoadOrExecutionTime| |setFFS|) |stream|)
+ (COND
+ ((|%hasFeature| :CLISP)
+ (COND ((NULL |$foreignsDefsForCLisp|) NIL)
+ (T
+ (SETQ |init|
+ (CONS 'PROGN
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |$foreignsDefsForCLisp|)
(|d| NIL))
(LOOP
(COND
- ((OR (NOT (CONSP |bfVar#4|))
+ ((OR (NOT (CONSP |bfVar#1|))
(PROGN
- (SETQ |d| (CAR |bfVar#4|))
+ (SETQ |d| (CAR |bfVar#1|))
NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5|
- #2=(CONS
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS
(LIST 'EVAL (|quote| |d|))
NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #2#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|))))))))
- (|reallyPrettyPrint| |init| |stream|))))
- (T NIL))))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (|reallyPrettyPrint| (|atLoadOrExecutionTime| |init|)
+ |stream|))))
+ (T NIL))))))
(DEFUN |genOptimizeOptions| (|stream|)
(|reallyPrettyPrint|
@@ -433,7 +416,7 @@
(SETQ |ps| (|makeParserState| |toks|))
(|bpFirstTok| |ps|)
(SETQ |found|
- (LET ((#1=#:G729
+ (LET ((#1=#:G734
(CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|))))
(COND
((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
@@ -512,6 +495,9 @@
(DEFUN |inAllContexts| (|x|)
(LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) |x|))
+(DEFUN |atLoadOrExecutionTime| (|x|)
+ (LIST 'EVAL-WHEN (LIST :LOAD-TOPLEVEL :EXECUTE) |x|))
+
(DEFUN |exportNames| (|ns|)
(COND ((NULL |ns|) NIL)
(T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|)))))))
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 20efc228..2e303001 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -287,7 +287,7 @@
((NOT
(AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
(RETURN NIL))
- ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|))))))
+ ((AND (CONSP |p|) (EQ |x| (CAR |p|))) (RETURN |p|))))))
(DEFUN |substitute!| (|y| |x| |s|)
(COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 8af76c86..8cea63a1 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2013, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -284,6 +284,12 @@ for i in [ _
["false", 'NIL] , _
["fifth", "FIFTH"] , _
["first", "CAR"] , _
+ ["filePath", "PATHNAME"] , _
+ ["filePath?", "PATHNAMEP"] , _
+ ["filePathDirectory", "PATHNAME-DIRECTORY"] , _
+ ["filePathName", "PATHNAME-NAME"] , _
+ ["filePathString", "NAMESTRING"] , _
+ ["filePathType", "PATHNAME-TYPE"] , _
["float?", "FLOATP"] , _
["flushOutput", "FORCE-OUTPUT"], _
["fourth", "CADDDR"] , _
@@ -297,6 +303,7 @@ for i in [ _
["list", "LIST"] , _
["listEq?", "EQUAL"] , _
["lowerCase?", "LOWER-CASE-P"], _
+ ["makeFilePath", "MAKE-PATHNAME"] , _
["makeSymbol", "INTERN"] , _
["mkpf", "MKPF"] , _
["newVector", "MAKE-ARRAY"], _
diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp
index e94a77d9..7a69738f 100644
--- a/src/interp/nlib.lisp
+++ b/src/interp/nlib.lisp
@@ -50,8 +50,7 @@
(if (null stream)
(if missing-file-error-flag
(ERROR (format nil "Library ~s doesn't exist"
- ;;(make-filename (cdr file) 'LISPLIB))
- (make-filename (cdr file) 'NIL)))
+ (|makeFilename| (cdr file) 'NIL)))
NIL)
(|makeLibstream| 'input fullname
(get-index-table-from-stream stream)
@@ -183,7 +182,7 @@
;; filearg is filespec or 1, 2 or 3 ids
;; (RPACKFILE filearg) -- compiles code files and converts to compressed format
(defun rpackfile (filespec)
- (setq filespec (make-filename filespec))
+ (setq filespec (|makeFilename| filespec))
(if (string= (pathname-type filespec) "NRLIB")
(recompile-lib-file-if-necessary
(concat (namestring filespec) "/code.lsp"))
@@ -242,37 +241,9 @@
(mapcar #'string keys))
(putindextable ctable filearg))
-;; cms file operations
-(defun make-filename (filearg &optional (filetype nil))
- (let ((filetype (if (symbolp filetype)
- (symbol-name filetype)
- filetype)))
- (cond
- ((pathnamep filearg)
- (cond ((pathname-type filearg) (namestring filearg))
- (t (namestring (make-pathname :directory (pathname-directory filearg)
- :name (pathname-name filearg)
- :type filetype)))))
- ;; Previously, given a filename containing "." and
- ;; an extension this function would return filearg. MCD 23-8-95.
- ((and (stringp filearg) (pathname-type filearg) (null filetype)) filearg)
- ;; ((and (stringp filearg)
- ;; (or (pathname-type filearg) (null filetype)))
- ;; filearg)
- ((and (stringp filearg) (stringp filetype)
- (pathname-type filearg)
- (string-equal (pathname-type filearg) filetype))
- filearg)
- ((consp filearg)
- (make-filename (car filearg) (or (cadr filearg) filetype)))
- (t (if (stringp filetype) (setq filetype (intern filetype "BOOT")))
- (let ((ft (or (cdr (assoc filetype $filetype-table)) filetype)))
- (if ft
- (concatenate 'string (string filearg) "." (string ft))
- (string filearg)))))))
(defun make-full-namestring (filearg &optional (filetype nil))
- (namestring (merge-pathnames (make-filename filearg filetype))))
+ (namestring (merge-pathnames (|makeFilename| filearg filetype))))
(defun get-directory-list (ft)
(let ((cd (get-current-directory)))
@@ -288,7 +259,7 @@
(defun make-input-filename (filearg &optional (filetype nil))
(let*
- ((filename (make-filename filearg filetype))
+ ((filename (|makeFilename| filearg filetype))
(dirname (pathname-directory filename))
(ft (pathname-type filename))
(dirs (get-directory-list ft))
diff --git a/src/interp/pathname.boot b/src/interp/pathname.boot
index 3dece48d..1a3bc6b3 100644
--- a/src/interp/pathname.boot
+++ b/src/interp/pathname.boot
@@ -51,7 +51,7 @@ pathname p ==
pathname? p => p
p isnt [.,:.] => PATHNAME p
if #p>2 then p:=[p.0,p.1]
- PATHNAME apply(FUNCTION MAKE_-FILENAME, p)
+ PATHNAME apply(function makeFilename, p)
namestring p ==
null p => nil
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index d3a8c18d..6c7afa17 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -427,3 +427,21 @@ addCompilerOption(key,val) ==
st := outputTextFile strconc(libDirname val,'"/code.lsp")
$compilerOptions := [['COMPILER_-OUTPUT_-STREAM,:st],:$compilerOptions]
nil
+
+makeFilename(filearg,filetype==nil) ==
+ if ident? filetype then
+ filetype := symbolName filetype
+ filePath? filearg => filePathString
+ filePathType filearg ~= nil => filearg
+ makeFilePath(directory <- filePathDirectory filearg,
+ name <- filePathName filearg, type <- filetype)
+ string? filearg and filePathType filearg ~= nil and filetype = nil => filearg
+ string? filearg and string? filetype and filePathType filearg ~= nil
+ and stringEq?(filePathType filearg,filetype) => filearg
+ filearg is [.,:.] =>
+ makeFilename(first filearg,second filearg or filetype)
+ if string? filetype then
+ filetype := makeSymbol filetype
+ ft := rest symbolAssoc(filetype,$FILETYPE_-TABLE) or filetype
+ ft = nil => toString filearg
+ strconc(toString filearg,'".",toString ft)
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index a6a0aa3a..28602764 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -932,7 +932,7 @@
(declare (ignore width) (ignore recnum))
(cond ((numberp filespec) (make-synonym-stream '*standard-output*))
((null filespec) (error "not handled yet"))
- (t (open (make-filename filespec) :direction :output
+ (t (open (|makeFilename| filespec) :direction :output
:if-exists :supersede))))
(defun MAKE-APPENDSTREAM (filespec &optional (width nil) (recnum 0))
@@ -941,7 +941,7 @@
(cond
((numberp filespec) (make-synonym-stream '*standard-output*))
((null filespec) (error "make-appendstream: not handled yet"))
- ('else (open (make-filename filespec) :direction :output
+ ('else (open (|makeFilename| filespec) :direction :output
:if-exists :append :if-does-not-exist :create))))
(defun DEFIOSTREAM (stream-alist buffer-size char-position)
@@ -954,7 +954,7 @@
((OUTPUT O) (make-synonym-stream '*standard-output*))
((INPUT I) (make-synonym-stream '*standard-input*)))
(let ((strm (case mode
- ((OUTPUT O) (open (make-filename filename)
+ ((OUTPUT O) (open (|makeFilename| filename)
:direction :output))
((INPUT I) (open (make-input-filename filename)
:direction :input)))))
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 01:42:04 +0000