genworks.lisp 5.12 KB
Newer Older
1
;;
Dave Cooper's avatar
Dave Cooper committed
2
;; Copyright 2002-2011, 2012 Genworks International
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;

;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 

22
23
24
25
26
(in-package :com.genworks.lisp)

(defparameter *fasl-extension*
    #+allegro excl:*fasl-default-type*
    #+lispworks compiler:*fasl-extension-string*
Dave Cooper's avatar
Dave Cooper committed
27
    #+sbcl sb-fasl:*fasl-file-type*
28
    #+ccl (namestring ccl:*.fasl-pathname*)
29
    #+abcl "abcl"
30
31
    #+clisp "fas"
    #-(or allegro lispworks sbcl ccl abcl clisp) (error "Need fasl extension string for the currently running lisp.~%"))
32
33


34
35
36
#-(or allegro lispworks sbcl ccl) 
(warn "~&Please implement concatenate-fasls for the currently running lisp.~%")

37
(defun concatenate-fasls (files dest)
38
  #-(or allegro lispworks sbcl ccl) (declare (ignore files dest))
39
  #-(or allegro lispworks sbcl ccl) (error "~&Please implement concatenate-fasls for the currently running lisp.~%")
40

41
  
Dave Cooper's avatar
Dave Cooper committed
42
  #+(or allegro sbcl)
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
  ;;
  ;; Provided by Franz:
  ;;
  ;; copy the contents of all files to the file named dest.
  ;; append .fasl to the filenames
  (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8))))
    (with-open-file (p dest :direction :output
                     :if-exists :supersede
                     :element-type '(unsigned-byte 8))
      (dolist (file files)
        (with-open-file (in (if (pathname-type file)
                                file
                              (format nil "~a.~a" file *fasl-extension*))
                         :element-type '(unsigned-byte 8))
          (do ((count (read-sequence buffer in) (read-sequence buffer in)))
              ((<= count 0))
            (cl:write-sequence buffer p :end count))))))

  #+lispworks
    ;; created a defsystem on the fly and use concatenate-system.
  (let ((defsys (concatenate `string
                  (format nil "(defsystem gdl::my-system () :members (")
                  (let (result
                        (bin-files (mapcar #'(lambda(bin-file)
                                               (namestring bin-file))
                                           files)))
                    (dolist (file bin-files)
                      (setq result (concatenate 'string result (format nil "~s~%" file))))
                    result)
                  (format nil "))~%"))))
    (eval (read-from-string defsys))
74
75
76
    (lispworks:concatenate-system dest 'my-system))

  #+ccl (ccl:fasl-concatenate dest files :if-exists :supersede))
77
78


79
80
(defvar *wild-entry*
  (make-pathname :name :wild :type :wild :version :wild))
81
82

(defun directory-list (pathspec)
83
84
85
86
87
88
  "(derived from quicklisp ql-impl-util:directory-entries): 
Return all directory entries of DIRECTORY as a
list, or NIL if there are no directory entries. Excludes the \".\"
and \"..\" entries."

  #+allegro
89
90
  (directory pathspec :directories-are-files nil)

91
  #+lispworks
92
  (directory (merge-pathnames *wild-entry* pathspec)
93
94
              :directories t
              :link-transparency nil)
95
  #+sbcl
96
  (directory (merge-pathnames *wild-entry* pathspec)
97
98
             :resolve-symlinks nil)
  #+ccl
99
100
101
102
  (directory (merge-pathnames *wild-entry* pathspec)
                :directories t)
  #+abcl
  (directory (merge-pathnames *wild-entry* pathspec)
103
104
105
106
107
108
109
110
                :resolve-symlinks  nil)
  
  #+clisp
  (mapcar 'first
            (nconc (directory (merge-pathnames *wild-entry* directory)
                               :full  t)
                   (directory (merge-pathnames *wild-relative* directory)
                               :full  t))))
Dave Cooper's avatar
Dave Cooper committed
111

112

Dave Cooper's avatar
Dave Cooper committed
113
114
(defun file-directory-p (file)
  "Returns non-nil if the path is a directory."
115
  (#-(or allegro lispworks) cl-fad:directory-pathname-p 
Dave Cooper's avatar
Dave Cooper committed
116
117
118
     #+allegro excl:file-directory-p 
     #+lispworks lw:file-directory-p file))

119
120
121
122
123
124
125
126
;;
;; temporary-folder is potentially platform-specific so it is defined here. 
;;
(defun temporary-folder (&key (create? t))
  (let ((folder (merge-pathnames "tmp/" (user-homedir-pathname))))
    (when create? (ensure-directories-exist folder))))

(defun temporary-file (&key (extension nil) create?)
127
  (let ((file (merge-pathnames (make-pathname :name (string (gensym))
128
129
130
131
                                              :type extension)
                               (temporary-folder))))
    (when create? 
      (with-open-file 
132
133
          (out file :direction :output :if-does-not-exist :create :if-exists :append)
	(declare (ignore out))))
134
135
136
137
138
139
    ;;
    ;; FLAG -- change this to return true pathname, fix code which uses it
    ;;
    (namestring file)))


Dave Cooper's avatar
Dave Cooper committed
140

141