From cbd17230112800448956940165f541d7c49d0dc5 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sun, 26 May 2013 06:42:43 +0000 Subject: Rename MAKE-FILENAME to makeFilename and re-implement in Boot. --- src/ChangeLog | 9 +++++ src/boot/strap/ast.clisp | 4 ++ src/boot/strap/parser.clisp | 4 +- src/boot/strap/tokens.clisp | 22 +++++++---- src/boot/strap/translator.clisp | 88 +++++++++++++++++------------------------ src/boot/strap/utility.clisp | 2 +- src/boot/tokens.boot | 9 ++++- src/interp/nlib.lisp | 37 ++--------------- src/interp/pathname.boot | 2 +- src/interp/sys-utility.boot | 18 +++++++++ src/interp/vmlisp.lisp | 6 +-- 11 files changed, 101 insertions(+), 100 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index e36e3649..43ce7ad2 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,12 @@ +2013-05-26 Gabriel Dos Reis + + * 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 * interp/nlib.lisp (ADDOPTIONS): Move to sys-utility.boot. 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))))) -- cgit v1.2.3