mirror/freebsd-ports
1
0
Fork 0
mirror of https://git.FreeBSD.org/ports.git synced 2024-10-19 19:59:43 +00:00
Code Issues Releases Activity

Fix brokenness when installed with slib-guile versions >= 3a2.

Browse Source 
This should fix one of gnucash's many problems.

PR:		ports/93066 [1] [2], ports/93983 [3]
Submitted by:	Geoffrey Mainland [1],
		Robert Backhaus provided the fix [2],
		Emilio Conti [3]
This commit is contained in:
Sam Lawrance 2006-06-08 15:54:14 +00:00
parent 5668601630
commit 8e4e7a9cc0
Notes: svn2git 2021-03-31 03:12:20 +00:00 
svn path=/head/; revision=164836
2 changed files with 86 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lang/guile/Makefile
View File

@ -7,6 +7,7 @@
PORTNAME= guile
PORTVERSION= 1.6.7
PORTREVISION= 1
CATEGORIES= lang scheme
MASTER_SITES= ${MASTER_SITE_GNU}
MASTER_SITE_SUBDIR= guile

85
lang/guile/files/patch-slib_slib.scm Normal file
View File

@ -0,0 +1,85 @@
Submitted By: Randy McMurchy <randy_at_linuxfromscratch_dot_org>
Date: 2005-10-04
Initial Package Version: 1.6.7
Upstream Status: Unknown
Origin: http://article.gmane.org/gmane.comp.gnome.apps.gnucash.devel/13956
Description: Fixes Guile with SLIB >= 3a2
diff -Naur guile-1.6.7-orig/ice-9/slib.scm guile-1.6.7/ice-9/slib.scm
--- ice-9/slib.scm 2004-08-11 20:04:21.000000000 -0500
+++ ice-9/slib.scm 2005-10-04 19:48:04.000000000 -0500
@@ -388,3 +388,74 @@
(define (make-exchanger obj)
(lambda (rep) (let ((old obj)) (set! obj rep) old)))
+
+(define software-type
+ (if (string<? (version) "1.6")
+ (lambda () 'UNIX)
+ (lambda () 'unix)))
+
+(define (user-vicinity)
+ (case (software-type)
+ ((VMS) "[.]")
+ (else "")))
+
+(define vicinity:suffix?
+ (let ((suffi
+ (case (software-type)
+ ((amiga) '(#\: #\/))
+ ((macos thinkc) '(#\:))
+ ((ms-dos windows atarist os/2) '(#\\ #\/))
+ ((nosve) '(#\: #\.))
+ ((unix coherent plan9) '(#\/))
+ ((vms) '(#\: #\]))
+ (else
+ (warn "require.scm" 'unknown 'software-type (software-type))
+ "/"))))
+ (lambda (chr) (and (memv chr suffi) #t))))
+
+(define (pathname->vicinity pathname)
+ (let loop ((i (- (string-length pathname) 1)))
+ (cond ((negative? i) "")
+ ((vicinity:suffix? (string-ref pathname i))
+ (substring pathname 0 (+ i 1)))
+ (else (loop (- i 1))))))
+
+(define (program-vicinity)
+ (define clp (current-load-port))
+ (if clp
+ (pathname->vicinity (port-filename clp))
+ (slib:error 'program-vicinity " called; use slib:load to load")))
+
+(define sub-vicinity
+ (case (software-type)
+ ((VMS) (lambda
+ (vic name)
+ (let ((l (string-length vic)))
+ (if (or (zero? (string-length vic))
+ (not (char=? #\] (string-ref vic (- l 1)))))
+ (string-append vic "[" name "]")
+ (string-append (substring vic 0 (- l 1))
+ "." name "]")))))
+ (else (let ((*vicinity-suffix*
+ (case (software-type)
+ ((NOSVE) ".")
+ ((MACOS THINKC) ":")
+ ((MS-DOS WINDOWS ATARIST OS/2) "\\")
+ ((unix COHERENT PLAN9 AMIGA) "/"))))
+ (lambda (vic name)
+ (string-append vic name *vicinity-suffix*))))))
+
+(define with-load-pathname
+ (let ((exchange
+ (lambda (new)
+ (let ((old program-vicinity))
+ (set! program-vicinity new)
+ old))))
+ (lambda (path thunk)
+ (define old #f)
+ (define vic (pathname->vicinity path))
+ (dynamic-wind
+ (lambda () (set! old (exchange (lambda () vic))))
+ thunk
+ (lambda () (exchange old))))))
+