~ chicken-core (chicken-5) bb47d6b383011082f8a0d4666f8e30759d689fc4
commit bb47d6b383011082f8a0d4666f8e30759d689fc4
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 4 13:29:16 2025 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 4 13:29:16 2025 +0100
use default make-pathname, drop platform nonsense for qs*
diff --git a/chicken-install.scm b/chicken-install.scm
index c2c7640f..866d0bec 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -295,11 +295,11 @@
(define (load-defaults)
(let* ((cfg-dir (system-config-directory))
- (user-file (and cfg-dir (make-pathname+ (list cfg-dir "chicken")
+ (user-file (and cfg-dir (make-pathname (list cfg-dir "chicken")
+defaults-file+)))
(deff (or user-defaults
(and user-file (file-exists? user-file))
- (make-pathname+ host-sharedir +defaults-file+))))
+ (make-pathname host-sharedir +defaults-file+))))
(define (broken x)
(error "invalid entry in defaults file" deff x))
(cond ((not (file-exists? deff)) '())
@@ -421,11 +421,11 @@
;; location, also make sure it is up to date
(define (locate-egg name version)
- (let* ((cached (make-pathname+ cache-directory name))
- (metadata-dir (make-pathname+ cache-metadata-directory name))
+ (let* ((cached (make-pathname cache-directory name))
+ (metadata-dir (make-pathname cache-metadata-directory name))
(now (current-seconds))
- (status (make-pathname+ metadata-dir +status-file+))
- (eggfile (make-pathname+ cached name +egg-extension+)))
+ (status (make-pathname metadata-dir +status-file+))
+ (eggfile (make-pathname cached name +egg-extension+)))
(define (fetch lax)
(when (file-exists? cached)
(delete-directory cached #t))
@@ -457,8 +457,8 @@
(error "cached egg does not match CHICKEN version - use `-force' to install anyway" name)))
(else (fetch #f)))))
(let* ((info (validate-egg-info (load-egg-info eggfile)))
- (vfile (make-pathname+ metadata-dir +version-file+))
- (tfile (make-pathname+ metadata-dir +timestamp-file+))
+ (vfile (make-pathname metadata-dir +version-file+))
+ (tfile (make-pathname metadata-dir +timestamp-file+))
(lversion (or (get-egg-property info 'version)
(and (file-exists? vfile)
(with-input-from-file vfile read)))))
@@ -493,33 +493,33 @@
;;
;; Return (values <egg-dir> <version>). <egg-dir> and <version>
;; will be #f in case they cannot be determined.
- (let ((egg-dir (probe-dir (make-pathname+ location egg-name))))
+ (let ((egg-dir (probe-dir (make-pathname location egg-name))))
(cond
((not egg-dir)
(values #f #f))
;; <location>/<egg-name>/<egg-name>.egg
- ((file-exists? (make-pathname+ egg-dir egg-name +egg-extension+))
+ ((file-exists? (make-pathname egg-dir egg-name +egg-extension+))
(values egg-dir #f))
(else
;; <location>/<egg-name>/<version>/<egg-name>.egg
(if version
- (values (probe-dir (make-pathname+ egg-dir (->string version)))
+ (values (probe-dir (make-pathname egg-dir (->string version)))
version)
(let ((versions (directory egg-dir)))
(if (null? versions)
(values #f #f)
(let ((latest (car (sort versions version>=?))))
- (values (make-pathname+ egg-dir (->string latest))
+ (values (make-pathname egg-dir (->string latest))
latest)))))))))
(define (write-cache-metadata egg egg-version)
- (let ((metadata-dir (make-pathname+ cache-metadata-directory egg)))
+ (let ((metadata-dir (make-pathname cache-metadata-directory egg)))
(when egg-version
- (with-output-to-file (make-pathname+ metadata-dir +version-file+)
+ (with-output-to-file (make-pathname metadata-dir +version-file+)
(cut write egg-version)))
- (with-output-to-file (make-pathname+ metadata-dir +timestamp-file+)
+ (with-output-to-file (make-pathname metadata-dir +timestamp-file+)
(cut write (current-seconds)))
- (with-output-to-file (make-pathname+ metadata-dir +status-file+)
+ (with-output-to-file (make-pathname metadata-dir +status-file+)
(cut write current-status))))
(define (fetch-egg-sources name version dest lax)
@@ -554,7 +554,7 @@
(receive (dir version-from-path)
(locate-local-egg-dir (car locs) name version)
(if dir
- (let* ((eggfile (make-pathname+ dir name +egg-extension+))
+ (let* ((eggfile (make-pathname dir name +egg-extension+))
(info (validate-egg-info (load-egg-info eggfile)))
(rversion
;; If version-from-path is non-#f, prefer it
@@ -581,12 +581,12 @@
(let ((cmd (string-append
(copy-directory-command platform)
" "
- (qs* f platform #t)
+ (qs* f)
" "
- (qs* to platform #t))))
+ (qs* to))))
(d "~a~%" cmd)
(system+ cmd platform)))
- (glob (make-pathname+ from "*"))))
+ (glob (make-pathname from "*"))))
(define (check-remote-version name lversion cached)
(let loop ((locs default-locations))
@@ -599,9 +599,9 @@
(loop (cdr srvs)))))))
;; The order of probe-dir's here is important. First try
;; the path with version, then the path without version.
- ((or (probe-dir (make-pathname+ (list (car locs) name)
+ ((or (probe-dir (make-pathname (list (car locs) name)
(->string lversion)))
- (probe-dir (make-pathname+ (car locs) name)))
+ (probe-dir (make-pathname (car locs) name)))
=> (lambda (dir)
;; for locally available eggs, check set of files and
;; timestamps
@@ -615,8 +615,8 @@
(hfs (directory here)))
(every (lambda (f)
(and (member f hfs)
- (let ((tf2 (make-pathname+ there f))
- (hf2 (make-pathname+ here f)))
+ (let ((tf2 (make-pathname there f))
+ (hf2 (make-pathname here f)))
(and (<= (file-modification-time tf2)
(file-modification-time hf2))
(if (directory-exists? tf2)
@@ -629,7 +629,7 @@
;; check installed eggs for already installed files
(define (matching-installed-files egg fnames)
- (let ((eggs (glob (make-pathname+ (install-path) "*" +egg-info-extension+))))
+ (let ((eggs (glob (make-pathname (install-path) "*" +egg-info-extension+))))
(let loop ((eggs eggs) (same '()))
(cond ((null? eggs) same)
((string=? egg (pathname-file (car eggs)))
@@ -684,7 +684,7 @@
(unless (member (car e+d+v) checked-eggs)
(d "checking ~a ...~%" (car e+d+v))
(set! checked-eggs (cons (car e+d+v) checked-eggs))
- (let* ((fname (make-pathname+ (cadr e+d+v) (car e+d+v) +egg-extension+))
+ (let* ((fname (make-pathname (cadr e+d+v) (car e+d+v) +egg-extension+))
(info (validate-egg-info (load-egg-info fname))))
(d "checking platform for `~a'~%" (car e+d+v))
(check-platform (car e+d+v) info)
@@ -783,7 +783,7 @@
(cond ((or (eq? x 'chicken) (equal? x "chicken"))
(chicken-version))
((let* ((sf (chicken.load#find-file
- (make-pathname+ #f (->string x) +egg-info-extension+)
+ (make-pathname #f (->string x) +egg-info-extension+)
(repo-path))))
(and sf
(file-exists? sf)
@@ -878,10 +878,10 @@
(lambda (egg)
(let* ((name (car egg))
(dir (cadr egg))
- (metadata-dir (make-pathname+ cache-metadata-directory name))
- (eggfile (make-pathname+ dir name +egg-extension+))
+ (metadata-dir (make-pathname cache-metadata-directory name))
+ (eggfile (make-pathname dir name +egg-extension+))
(info (load-egg-info eggfile))
- (vfile (make-pathname+ metadata-dir +version-file+))
+ (vfile (make-pathname metadata-dir +version-file+))
(ver (and (file-exists? vfile)
(with-input-from-file vfile read))))
(when (or host-extension
@@ -892,9 +892,9 @@
ver
platform
'host)))
- (let ((bscript (make-pathname+ dir name
+ (let ((bscript (make-pathname dir name
(build-script-extension 'host)))
- (iscript (make-pathname+ dir name
+ (iscript (make-pathname dir name
(install-script-extension 'host))))
(generate-shell-commands platform build bscript dir
(build-prefix 'host name info)
@@ -924,9 +924,9 @@
ver
platform
'target)))
- (let ((bscript (make-pathname+ dir name
+ (let ((bscript (make-pathname dir name
(build-script-extension 'target)))
- (iscript (make-pathname+ dir name
+ (iscript (make-pathname dir name
(install-script-extension 'target))))
(generate-shell-commands platform build bscript dir
(build-prefix 'target name info)
@@ -957,14 +957,14 @@
(let* ((name (car egg))
(dir (cadr egg))
(version (caddr egg))
- (testdir (make-pathname+ dir "tests"))
- (tscript (make-pathname+ testdir "run.scm")))
+ (testdir (make-pathname dir "tests"))
+ (tscript (make-pathname testdir "run.scm")))
(if (and (directory-exists? testdir)
(file-exists? tscript))
(let ((old (current-directory))
- (cmd (string-append (qs* default-csi platform)
- " -s " (qs* tscript platform)
- " " (qs* name platform)
+ (cmd (string-append (qs* default-csi)
+ " -s " (qs* tscript)
+ " " (qs* name)
" " (or version ""))))
(change-directory testdir)
(d "running: ~a~%" cmd)
@@ -990,7 +990,7 @@
(get-environment-variable "DYLD_LIBRARY_PATH"))))
(if dyld
(string-append "/usr/bin/env DYLD_LIBRARY_PATH="
- (qs* dyld platform)
+ (qs* dyld)
" ")
""))
"sh " script))
@@ -1009,8 +1009,8 @@
;;; update module-db
(define (update-db)
- (let* ((files (glob (make-pathname+ (install-path) "*.import.so")
- (make-pathname+ (install-path) "*.import.scm")))
+ (let* ((files (glob (make-pathname (install-path) "*.import.so")
+ (make-pathname (install-path) "*.import.scm")))
(dbfile (create-temporary-file)))
(print "loading import libraries ...")
(fluid-let ((##sys#warnings-enabled #f))
@@ -1047,7 +1047,7 @@
(lambda ()
(for-each (lambda (x) (write x) (newline)) db)))
(unless quiet (print "installing " +module-db+ " ..."))
- (copy-file dbfile (make-pathname+ (install-path) +module-db+) #t)
+ (copy-file dbfile (make-pathname (install-path) +module-db+) #t)
(delete-file dbfile))))
@@ -1062,8 +1062,8 @@
(for-each
(lambda (egg)
(let* ((name (if (pair? egg) (car egg) egg))
- (cache-dir (make-pathname+ cache-directory name))
- (metadata-dir (make-pathname+ cache-metadata-directory name)))
+ (cache-dir (make-pathname cache-directory name))
+ (metadata-dir (make-pathname cache-metadata-directory name)))
(when (file-exists? cache-dir)
(d "purging ~a from cache at ~a~%" name cache-dir)
(delete-directory cache-dir #t))
diff --git a/egg-compile.scm b/egg-compile.scm
index 33fcf237..5b0ec042 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -139,7 +139,7 @@
(if (irregex-search '(: bos ".." ("\\/")) dest*)
(error "destination must be relative to CHICKEN install prefix" dest)
(normalize-pathname
- (make-pathname+ (if (eq? mode 'target)
+ (make-pathname (if (eq? mode 'target)
default-prefix
(override-prefix "/" host-prefix))
dest*)))))
@@ -946,18 +946,16 @@
(object-extension platform)
(archive-extension platform)))
(sname (prefix srcdir name))
- (out (qs* (target-file (conc sname ".static" ext) mode)
- platform #t))
- (outlnk (qs* (conc sname +link-file-extension+) platform #t))
+ (out (qs* (target-file (conc sname ".static" ext) mode)))
+ (outlnk (qs* (conc sname +link-file-extension+)))
(dest (effective-destination-repository mode))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR")))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (qs* (conc dest "/" output-file ext) platform #t))
+ (qs* (conc dest "/" output-file ext)))
(print cmd " " outlnk " " ddir
- (qs* (conc dest "/" output-file +link-file-extension+)
- platform #t))
+ (qs* (conc dest "/" output-file +link-file-extension+)))
(print-end-command platform)))
(define ((install-dynamic-extension name #!key mode (ext ".so")
@@ -966,11 +964,11 @@
(let* ((cmd (install-executable-command platform))
(mkdir (mkdir-command platform))
(sname (prefix srcdir name))
- (out (qs* (target-file (conc sname ext) mode) platform #t))
+ (out (qs* (target-file (conc sname ext) mode)))
(dest (effective-destination-repository mode))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform))
- (destf (qs* (conc dest "/" output-file ext) platform #t)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR"))
+ (destf (qs* (conc dest "/" output-file ext))))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir destf)
(print-end-command platform)))
@@ -986,42 +984,39 @@
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
(sname (prefix srcdir name))
- (out (qs* (target-file (conc sname ".import.scm") mode)
- platform #t))
+ (out (qs* (target-file (conc sname ".import.scm") mode)))
(dest (effective-destination-repository mode))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR")))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (qs* (conc dest "/" name ".import.scm") platform #t))
+ (qs* (conc dest "/" name ".import.scm")))
(print-end-command platform)))
(define ((install-types-file name #!key mode types-file)
srcdir platform)
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
- (out (qs* (prefix srcdir (conc types-file ".types"))
- platform #t))
+ (out (qs* (prefix srcdir (conc types-file ".types"))))
(dest (effective-destination-repository mode))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR")))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (qs* (conc dest "/" types-file ".types") platform #t))
+ (qs* (conc dest "/" types-file ".types")))
(print-end-command platform)))
(define ((install-inline-file name #!key mode inline-file)
srcdir platform)
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
- (out (qs* (prefix srcdir (conc inline-file ".inline"))
- platform #t))
+ (out (qs* (prefix srcdir (conc inline-file ".inline"))))
(dest (effective-destination-repository mode))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR")))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (qs* (conc dest "/" inline-file ".inline") platform #t))
+ (qs* (conc dest "/" inline-file ".inline")))
(print-end-command platform)))
(define ((install-program name #!key mode output-file) srcdir platform)
@@ -1029,13 +1024,13 @@
(mkdir (mkdir-command platform))
(ext (executable-extension platform))
(sname (prefix srcdir name))
- (out (qs* (target-file (conc sname ext) mode) platform #t))
+ (out (qs* (target-file (conc sname ext) mode)))
(dest (if (eq? mode 'target)
default-bindir
(override-prefix "/bin" host-bindir)))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform))
- (destf (qs* (conc dest "/" output-file ext) platform #t)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR"))
+ (destf (qs* (conc dest "/" output-file ext))))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir destf)
(print-end-command platform)))
@@ -1045,14 +1040,13 @@
(mkdir (mkdir-command platform))
(ext (object-extension platform))
(sname (prefix srcdir name))
- (out (qs* (target-file (conc sname ext) mode)
- platform #t))
+ (out (qs* (target-file (conc sname ext) mode)))
(dest (effective-destination-repository mode))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR")))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir
- (qs* (conc dest "/" output-file ext) platform #t))
+ (qs* (conc dest "/" output-file ext)))
(print-end-command platform)))
(define (install-random-files dest files mode srcdir platform)
@@ -1061,8 +1055,8 @@
(root (string-append srcdir "/"))
(mkdir (mkdir-command platform))
(sfiles (map (cut prefix srcdir <>) files))
- (dfile (qs* dest platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (dfile (qs* dest))
+ (ddir (shell-variable "DESTDIR")))
(print "\n" mkdir " " ddir dfile)
(let-values (((ds fs) (partition directory? sfiles)))
(for-each
@@ -1071,11 +1065,11 @@
(fdir (pathname-directory ds)))
(when fdir
(print mkdir " " ddir
- (qs* (make-pathname+ dest fdir) platform #t)))
+ (qs* (make-pathname dest fdir))))
(print dcmd " " (qs* d platform #t)
" " ddir
(if fdir
- (qs* (make-pathname+ dest fdir) platform #t)
+ (qs* (make-pathname dest fdir))
dfile))
(print-end-command platform)))
ds)
@@ -1086,11 +1080,11 @@
(fdir (pathname-directory fs)))
(when fdir
(print mkdir " " ddir
- (qs* (make-pathname+ dest fdir) platform #t)))
+ (qs* (make-pathname dest fdir))))
(print fcmd " " (qs* f platform)
" " ddir
(if fdir
- (qs* (make-pathname+ dest fdir) platform #t)
+ (qs* (make-pathname dest fdir))
dfile)))
(print-end-command platform))
fs)))))
@@ -1137,7 +1131,7 @@
(with-output-to-file dest
(lambda ()
(prefix platform)
- (print (cd-command platform) " " (qs* srcdir platform #t))
+ (print (cd-command platform) " " (qs* srcdir))
(for-each
(lambda (cmd) (cmd srcdir platform))
cmds)
@@ -1157,9 +1151,9 @@ export CHICKEN_CSC=~a
export CHICKEN_CSI=~a
EOF
- (qs* default-bindir platform) (qs* default-cc platform)
- (qs* default-cxx platform) (qs* default-csc platform)
- (qs* default-csi platform)))
+ (qs* default-bindir) (qs* default-cc)
+ (qs* default-cxx) (qs* default-csc)
+ (qs* default-csi)))
(define ((build-suffix mode name info) platform)
(printf #<<EOF
@@ -1179,10 +1173,9 @@ EOF
(dcmd (remove-file-command platform))
(mkdir (mkdir-command platform))
(dir (destination-repository mode))
- (qdir (qs* dir platform #t))
- (dest (qs* (make-pathname+ dir name +egg-info-extension+)
- platform #t))
- (ddir (shell-variable "DESTDIR" platform)))
+ (qdir (qs* dir))
+ (dest (qs* (make-pathname dir name +egg-info-extension+)))
+ (ddir (shell-variable "DESTDIR")))
(printf #<<EOF
~a ~a~a
@@ -1196,31 +1189,27 @@ EOF
;;; some utilities for mangling + quoting
-(define (qs* arg platform #!optional slashify?)
+(define (qs* arg)
(qs (->string arg)))
(define (prefix dir name)
- (make-pathname+ dir (->string name)))
+ (make-pathname dir (->string name)))
(define (system+ str platform)
(system (if (eq? platform 'windows)
(string-append "sh -c \"" str "\"")
str)))
-(define (make-pathname+ . args)
- (let ((p1 (apply make-pathname args)))
- (irregex-replace/all #\\ p1 "/")))
-
(define (target-file fname mode)
(if (eq? mode 'target) (string-append fname ".target") fname))
(define (joins strs platform)
- (string-intersperse (map (cut qs* <> platform) strs) " "))
+ (string-intersperse (map qs* strs) " "))
(define (filelist dir lst)
(map (cut prefix dir <>) lst))
-(define (shell-variable var platform)
+(define (shell-variable var)
(string-append "\"${" var "}\""))
(define prepare-custom-command void)
@@ -1229,7 +1218,7 @@ EOF
(and custom (prefix srcdir custom)))
(define (print-build-command targets sources command-and-args platform)
- (print "\n" (qs* default-builder platform) " "
+ (print "\n" (qs* default-builder) " "
(joins targets platform)
" : " (joins sources platform) " "
" : " (joins command-and-args platform)))
@@ -1239,7 +1228,7 @@ EOF
(define (strip-dir-prefix prefix fname)
(let* ((plen (string-length prefix))
(p1 (substring fname 0 plen)))
- (assert (string=? prefix p1) "wrong prefix")
+ (assert (string=? prefix p1) "wrong prefix" prefix p1)
(substring fname (add1 plen))))
(define (maybe f x) (if f (list x) '()))
Trap