Commit 846d20b8 authored by Erick Gallesio's avatar Erick Gallesio

Added FILE-PREFIX primitive

parent 7a328a54
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 22-Jan-2007 20:11 (eg)
;; Last file update: 22-Jan-2007 23:54 (eg)
;;
;; ======================================================================
......@@ -695,6 +695,7 @@ applications.])
(insertdoc 'basename)
(insertdoc 'dirname)
(insertdoc 'file-suffix)
(insertdoc 'file-prefix)
(insertdoc 'file-separator)
(insertdoc 'make-path)
(insertdoc 'glob))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 22-Jan-2007 20:10 (eg)
;;;; Last file update: 22-Jan-2007 23:53 (eg)
;;;;
;;
......@@ -1219,6 +1219,31 @@ doc>
(else
(loop (- i 1)))))))))
#|
<doc EXT file-prefix
* (file-prefix pathname)
*
* Returns the suffix of given |pathname|.
* @lisp
* (file-prefix "./foo.tar.gz") => "./foo.tar"
* (file-prefix "./a.b/c") => "./a.b/c"
* @end lisp
|#
(define (file-prefix pathname)
(let ((end (string-length pathname)))
(let loop ((i (- end 1)))
(if (< i 0)
pathname
(let ((c (string-ref pathname i)))
(cond
((char=? c #\.)
(substring pathname 0 i))
((char=? c (file-separator))
pathname)
(else
(loop (- i 1)))))))))
#|
<doc EXT port-idle-register! port-idle-unregister! port-idle-reset!
* (port-idle-register! port thunk)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Jan-2007 16:44 (eg)
;;;; Last file update: 19-Jan-2007 23:27 (eg)
;;;; Last file update: 22-Jan-2007 21:35 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -100,12 +100,32 @@
;;;; Tuning functions
;;;;
;;;; ======================================================================
(define (%snowman-replace-definitions! src replacements)
;; ----------------------------------------------------------------------
;; snowman-tune-package-declaration! ...
;; ----------------------------------------------------------------------
(define (snowman-tune-package-declaration! proc)
(let ((res (proc *package* "" *dir*)))
(unless (eq? res (void))
(set! *package* res)))
*package*)
;; ----------------------------------------------------------------------
;; snowman-tune-body! ...
;; ----------------------------------------------------------------------
(define (snowman-tune-body! proc)
(let ((res (proc *body* "" *dir*)))
(unless (eq? res (void))
(set! *body* res)))
*body*)
(define (snowman-subst-definitions src replacements)
(define (replace orig id)
(let ((c (assq id replacements)))
(if (pair? c)
(cadr c)
(begin (DEBUG "==> ~S" (cadr c)) (cadr c))
orig)))
(map (lambda (orig)
......@@ -121,33 +141,17 @@
orig)))
src))
;;//
;;// ;; ----------------------------------------------------------------------
;;// ;; snowman-replace-package-provide! ...
;;// ;; ----------------------------------------------------------------------
;;// (define (snowman-replace-package-provide! src replacements)
;;// (%snowman-replace-definitions! src replacements))
;;//
;;// ;; ----------------------------------------------------------------------
;;// ;; snowman-replace-body-definitions! ...
;;// ;; ----------------------------------------------------------------------
;;// (define (snowman-replace-body-definitions! src replacements)
;;// (%snowman-replace-definitions! src replacements))
;; ----------------------------------------------------------------------
;; snowman-tune-package-declaration! ...
;; ----------------------------------------------------------------------
(define (snowman-tune-package-declaration! proc)
(let ((res (proc *package* "" *dir*)))
(unless (eq? res (void))
(set! *package* res)))
*package*)
;; ----------------------------------------------------------------------
;; snowman-tune-body! ...
;; ----------------------------------------------------------------------
(define (snowman-tune-body! proc)
(let ((res (proc *body* "" *dir*)))
(unless (eq? res (void))
(set! *body* res)))
*body*)
;; ----------------------------------------------------------------------
;; snowman-replace-package-provide! ...
;; ----------------------------------------------------------------------
(define (snowman-replace-package-provide! src replacements)
(%snowman-replace-definitions! src replacements))
;; ----------------------------------------------------------------------
;; snowman-replace-body-definitions! ...
;; ----------------------------------------------------------------------
(define (snowman-replace-body-definitions! src replacements)
(%snowman-replace-definitions! src replacements))
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment