source: project/chicken/branches/hygienic/utils.scm @ 11524

Last change on this file since 11524 was 11524, checked in by felix winkelmann, 12 years ago

re-loading imported module into interpreter incorrectly renamed export list (export-lists are now sytax-stripped); started with guerilla setup

File size: 17.8 KB
Line 
1;;;; utils.scm - Utilities for scripting and file stuff
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit utils)
30  (uses regex data-structures extras)
31  (usual-integrations)
32  (fixnum)
33  (hide chop-pds)
34  (disable-interrupts) )
35
36(cond-expand
37 [paranoia]
38 [else
39  (declare
40    (always-bound
41      ##sys#windows-platform)
42    (bound-to-procedure
43      string-search string-match regexp regexp-escape
44      ##sys#symbol-has-toplevel-binding? ##sys#environment-symbols
45      ##sys#hash-table-for-each ##sys#macro-environment
46      ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
47      for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
48      decompose-pathname absolute-pathname? string-append ##sys#substring
49      delete-file system)
50    (no-procedure-checks-for-usual-bindings)
51    (no-bound-checks))] )
52
53(include "unsafe-declarations.scm")
54
55(register-feature! 'utils)
56
57
58;;; Environment utilities
59
60(define ##sys#apropos-interned)
61(define ##sys#apropos-macros)
62(let ([string-search string-search]
63      [regexp regexp]
64      [regexp-escape regexp-escape])
65  (let ([makpat
66         (lambda (patt)
67           (when (symbol? patt)
68             (set! patt (symbol->string patt)))
69           (when (string? patt)
70             (set! patt (regexp (regexp-escape patt))))
71           patt)])
72
73    (set! ##sys#apropos-interned
74      (lambda (patt env)
75        (set! patt (makpat patt))
76        (##sys#environment-symbols env
77          (lambda (sym)
78            (and (string-search patt (symbol->string sym))
79                 (##sys#symbol-has-toplevel-binding? sym) ) ) ) ) )
80
81    (set! ##sys#apropos-macros
82      (lambda (patt env) ; env is currently ignored
83        (set! patt (makpat patt))
84        (let ([ms '()])
85          (for-each
86           (lambda (a)
87             (let ((key (car a)))
88               (when (string-search patt (symbol->string key))
89                 (set! ms (cons key ms)) ) ) )
90           (##sys#macro-environment))
91          ms ) ) ) ) )
92
93(define (##sys#apropos patt env #!optional macf)
94  (let ([ts (##sys#apropos-interned patt env)])
95    (if macf
96        (##sys#append ts (##sys#apropos-macros patt env))
97        ts ) ) )
98
99(define apropos-list)
100(define apropos)
101(let ([%apropos-list
102        (lambda (loc patt args) ; #!optional (env (interaction-environment)) #!key macros?
103          (let ([env (interaction-environment)]
104                [macros? #f])
105            ; Handle extended lambda list optional & rest w/ keywords
106            (let loop ([args args])
107              (when (pair? args)
108                (let ([arg (car args)])
109                  (if (eq? #:macros? arg)
110                      (begin
111                        (set! macros? (cadr args))
112                        (loop (cddr args)) )
113                      (begin
114                        (set! env arg)
115                        (loop (cdr args)) ) ) ) ) )
116            (##sys#check-structure env 'environment loc)
117            (unless (or (string? patt) (symbol? patt) (regexp? patt))
118              (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" patt))
119            (##sys#apropos patt env macros?) ) )]
120      [disp-proc
121        (lambda (proc labl)
122          (let ([info (procedure-information proc)])
123            (cond [(pair? info) (display (cons labl (cdr info)))]
124                  [info         (display labl)]
125                  [else         (display labl) ] ) ) ) ]
126      [symlen
127        (lambda (sym)
128          (let ([len (##sys#size (##sys#symbol->qualified-string sym))])
129            (if (keyword? sym)
130                (fx- len 2) ; compensate for leading '###' when only a ':' is printed
131                len ) ) )])
132
133  (set! apropos-list
134    (lambda (patt . rest)
135      (%apropos-list 'apropos-list patt rest)))
136
137  (set! apropos
138    (lambda (patt . rest)
139      (let ([ss (%apropos-list 'apropos patt rest)]
140            [maxlen 0])
141        (for-each
142          (lambda (sym)
143            (set! maxlen (fxmax maxlen (symlen sym))))
144          ss)
145        (for-each
146          (lambda (sym)
147            (display sym)
148            (do ([i (fx- maxlen (symlen sym)) (fx- i 1)])
149                [(fx<= i 0)]
150              (display #\space))
151            (display #\space) (display #\:) (display #\space)
152            (if (macro? sym)
153                ;FIXME want to display macro lambda arguments
154                (display 'macro)
155                (let ([bnd (##core#inline "C_retrieve" sym)])
156                  (cond [(procedure? bnd)
157                          (disp-proc bnd 'procedure)]
158                        [else
159                          (display 'variable)]) ) )
160            (newline) )
161          ss)))) )
162
163
164;;; Like `system', but allows format-string and bombs on nonzero return code:
165
166(define system*
167  (let ([sprintf sprintf]
168        [system system] )
169    (lambda (fstr . args)
170      (let* ([str (apply sprintf fstr args)]
171             [n (system str)] )
172        (unless (zero? n)
173          (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
174
175
176;;; Like `delete-file', but does nothing if the file doesn't exist:
177
178(define delete-file*
179  (let ([file-exists? file-exists?]
180        [delete-file delete-file] )
181    (lambda (file)
182      (and (file-exists? file) (delete-file file) #t) ) ) )
183
184;;; file-copy and file-move : they do what you'd think.
185(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
186    (##sys#check-string origfile 'file-copy)
187    (##sys#check-string newfile 'file-copy)
188    (##sys#check-number blocksize 'file-copy)
189    (or (and (integer? blocksize) (> blocksize 0))
190        (##sys#error (string-append
191                         "invalid blocksize given: not a positive integer - "
192                         (number->string blocksize))))
193    (or (file-exists? origfile)
194        (##sys#error (string-append "origfile does not exist - " origfile)))
195    (and (file-exists? newfile)
196         (or clobber
197             (##sys#error (string-append
198                              "newfile exists but clobber is false - "
199                              newfile))))
200    (let* ((i   (condition-case (open-input-file origfile)
201                    (val ()
202                        (##sys#error (string-append
203                                         "could not open origfile for read - "
204                                         origfile)))))
205           (o   (condition-case (open-output-file newfile)
206                    (val ()
207                        (##sys#error (string-append
208                                         "could not open newfile for write - "
209                                         newfile)))))
210           (s   (make-string blocksize)))
211        (let loop ((d   (read-string! blocksize s i))
212                   (l   0))
213            (if (= 0 d)
214                (begin
215                    (close-input-port i)
216                    (close-output-port o)
217                    l)
218                (begin
219                    (condition-case (write-string s d o)
220                        (val ()
221                            (close-input-port i)
222                            (close-output-port o)
223                            (##sys#error (string-append
224                                             "error writing file starting at "
225                                             (number->string l)))))
226                    (loop (read-string! blocksize s i) (+ d l)))))))
227
228(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
229    (##sys#check-string origfile 'file-move)
230    (##sys#check-string newfile 'file-move)
231    (##sys#check-number blocksize 'file-move)
232    (or (and (integer? blocksize) (> blocksize 0))
233        (##sys#error (string-append
234                         "invalid blocksize given: not a positive integer - "
235                         (number->string blocksize))))
236    (or (file-exists? origfile)
237        (##sys#error (string-append "origfile does not exist - " origfile)))
238    (and (file-exists? newfile)
239         (or clobber
240             (##sys#error (string-append
241                              "newfile exists but clobber is false - "
242                              newfile))))
243    (let* ((i   (condition-case (open-input-file origfile)
244                    (val ()
245                        (##sys#error (string-append
246                                         "could not open origfile for read - "
247                                         origfile)))))
248           (o   (condition-case (open-output-file newfile)
249                    (val ()
250                        (##sys#error (string-append
251                                         "could not open newfile for write - "
252                                         newfile)))))
253           (s   (make-string blocksize)))
254        (let loop ((d   (read-string! blocksize s i))
255                   (l   0))
256            (if (= 0 d)
257                (begin
258                    (close-input-port i)
259                    (close-output-port o)
260                    (condition-case (delete-file origfile)
261                        (val ()
262                            (##sys#error (string-append
263                                             "could not remove origfile - "
264                                             origfile))))
265                    l)
266                (begin
267                    (condition-case (write-string s d o)
268                        (val ()
269                            (close-input-port i)
270                            (close-output-port o)
271                            (##sys#error (string-append
272                                             "error writing file starting at "
273                                             (number->string l)))))
274                    (loop (read-string! blocksize s i) (+ d l)))))))
275
276;;; Pathname operations:
277
278(define absolute-pathname?
279  (let ([string-match string-match]
280        [regexp regexp]
281        [string-append string-append])
282    (let* ([drv (if ##sys#windows-platform "([A-Za-z]:)?" "")]
283           [patt (make-anchored-pattern (string-append drv "[\\/\\\\].*"))]
284           [rx (regexp patt)] )
285      (lambda (pn)
286        (##sys#check-string pn 'absolute-pathname?)
287        (pair? (string-match rx pn)) ) ) ) )
288
289(define (chop-pds str pds)
290  (and str
291       (let ((len (##sys#size str))
292             (pdslen (if pds (##sys#size pds) 1)))
293         (if (and (fx>= len 1)
294                  (if pds
295                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
296                      (memq (##core#inline "C_subchar" str (fx- len pdslen))
297                            '(#\/ #\\) ) ) )
298             (##sys#substring str 0 (fx- len pdslen))
299             str) ) ) )
300
301(define make-pathname)
302(define make-absolute-pathname)
303(let ([string-append string-append]
304      [absolute-pathname? absolute-pathname?]
305      [def-pds "/"] )
306
307  (define (conc-dirs dirs pds)
308    (##sys#check-list dirs 'make-pathname)
309    (let loop ([strs dirs])
310      (if (null? strs)
311          ""
312          (let ((s1 (car strs)))
313            (if (zero? (string-length s1))
314                (loop (cdr strs))
315                (string-append
316                 (chop-pds (car strs) pds)
317                 (or pds def-pds)
318                 (loop (cdr strs))) ) ) ) ) )
319
320  (define (canonicalize-dirs dirs pds)
321    (cond [(or (not dirs) (null? dirs)) ""]
322          [(string? dirs) (conc-dirs (list dirs) pds)]
323          [else           (conc-dirs dirs pds)] ) )
324
325  (define (_make-pathname loc dir file ext pds)
326    (let ([ext (or ext "")]
327          [file (or file "")]
328          [pdslen (if pds (##sys#size pds) 1)] )
329      (##sys#check-string dir loc)
330      (##sys#check-string file loc)
331      (##sys#check-string ext loc)
332      (when pds (##sys#check-string pds loc))
333      (string-append
334       dir
335       (if (and (fx>= (##sys#size file) pdslen)
336                (if pds
337                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
338                    (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
339           (##sys#substring file pdslen (##sys#size file))
340           file)
341       (if (and (fx> (##sys#size ext) 0)
342                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
343           "."
344           "")
345       ext) ) )
346
347  (set! make-pathname
348    (lambda (dirs file #!optional ext pds)
349      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
350
351  (set! make-absolute-pathname
352    (lambda (dirs file #!optional ext pds)
353      (_make-pathname
354       'make-absolute-pathname
355       (let ([dir (canonicalize-dirs dirs pds)])
356         (if (absolute-pathname? dir)
357             dir
358             (##sys#string-append (or pds def-pds) dir)) )
359       file ext pds) ) ) )
360
361(define decompose-pathname
362  (let ([string-match string-match]
363        [regexp regexp]
364        [string-append string-append])
365    (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
366           [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
367           [rx1 (regexp patt1)]
368           [rx2 (regexp patt2)]
369           [strip-pds
370             (lambda (dir)
371                (and dir
372                     (if (member dir '("/" "\\"))
373                         dir
374                         (chop-pds dir #f) ) ) )] )
375      (lambda (pn)
376        (##sys#check-string pn 'decompose-pathname)
377        (if (fx= 0 (##sys#size pn))
378            (values #f #f #f)
379            (let ([ms (string-match rx1 pn)])
380              (if ms
381                  (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
382                  (let ([ms (string-match rx2 pn)])
383                    (if ms
384                        (values (strip-pds (cadr ms)) (caddr ms) #f)
385                        (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
386
387(define pathname-directory)
388(define pathname-file)
389(define pathname-extension)
390(define pathname-strip-directory)
391(define pathname-strip-extension)
392(define pathname-replace-directory)
393(define pathname-replace-file)
394(define pathname-replace-extension)
395(let ([decompose-pathname decompose-pathname])
396
397  (set! pathname-directory
398    (lambda (pn)
399      (let-values ([(dir file ext) (decompose-pathname pn)])
400        dir) ) )
401
402  (set! pathname-file
403    (lambda (pn)
404      (let-values ([(dir file ext) (decompose-pathname pn)])
405        file) ) )
406
407  (set! pathname-extension
408    (lambda (pn)
409      (let-values ([(dir file ext) (decompose-pathname pn)])
410        ext) ) )
411
412  (set! pathname-strip-directory
413    (lambda (pn)
414      (let-values ([(dir file ext) (decompose-pathname pn)])
415        (make-pathname #f file ext) ) ) )
416
417  (set! pathname-strip-extension
418    (lambda (pn)
419      (let-values ([(dir file ext) (decompose-pathname pn)])
420        (make-pathname dir file) ) ) )
421
422  (set! pathname-replace-directory
423    (lambda (pn dir)
424      (let-values ([(_ file ext) (decompose-pathname pn)])
425        (make-pathname dir file ext) ) ) )
426
427  (set! pathname-replace-file
428    (lambda (pn file)
429      (let-values ([(dir _ ext) (decompose-pathname pn)])
430        (make-pathname dir file ext) ) ) )
431
432  (set! pathname-replace-extension
433    (lambda (pn ext)
434      (let-values ([(dir file _) (decompose-pathname pn)])
435        (make-pathname dir file ext) ) ) ) )
436
437(define create-temporary-file
438  (let ([getenv getenv]
439        [make-pathname make-pathname]
440        [file-exists? file-exists?]
441        [call-with-output-file call-with-output-file] )
442    (lambda (#!optional (ext "tmp"))
443      (let ([dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP") "/tmp")])
444        (##sys#check-string ext 'create-temporary-file)
445        (let loop ()
446          (let* ([n (##sys#fudge 16)]
447                 [pn (make-pathname dir (##sys#string-append "t" (number->string n 16)) ext)] )
448            (cond ((file-exists? pn) (loop))
449                  (else (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) ) )
450
451;; Directory string or list only contains path-separators
452;; and/or current-directory names.
453
454(define (directory-null? dir)
455  (let loop ([lst
456              (if (list? dir)
457                  dir ; Don't bother to check for strings here
458                  (begin
459                    (##sys#check-string dir 'directory-null?)
460                    (string-split dir "/\\" #t)))])
461    (or (null? lst)
462        (and (member (car lst) '("" "."))
463             (loop (cdr lst)) ) ) ) )
464
465;;; Handy I/O procedures:
466
467(define for-each-line
468  (let ([read-line read-line])
469    (lambda (proc . port)
470      (let ([port (if (pair? port) (car port) ##sys#standard-input)])
471        (##sys#check-port port 'for-each-line)
472        (let loop ()
473          (let ([ln (read-line port)])
474            (unless (eof-object? ln)
475              (proc ln)
476              (loop) ) ) ) ) ) ) )
477
478
479;; This one is from William Annis:
480
481(define (for-each-argv-line thunk)
482  (define (file-iterator file thunk)
483    (if (string=? file "-")
484        (for-each-line thunk)
485        (with-input-from-file file (cut for-each-line thunk) ) ) )
486  (let ((args (command-line-arguments)))
487    (if (null? args)
488        ;; If no arguments, take from stdin,
489        (for-each-line thunk)
490        ;; otherwise, hit each file named in argv.
491        (for-each (lambda (arg) (file-iterator arg thunk)) args))))
492
493
494;;; Read file as string from given filename or port:
495
496(define (read-all . file)
497  (let ([file (optional file ##sys#standard-input)])
498    (if (port? file)
499        (read-string #f file)
500        (with-input-from-file file (cut read-string #f)) ) ) )
Note: See TracBrowser for help on using the repository browser.