Rename MAKE-FILENAME to makeFilename and re-implement in Boot.

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)))))