unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* Fixing the slib mess
@ 2012-10-21 23:11 Mikael Djurfeldt
  2012-10-22 18:31 ` Stefan Israelsson Tampe
                   ` (3 more replies)
  0 siblings, 4 replies; 13+ messages in thread
From: Mikael Djurfeldt @ 2012-10-21 23:11 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 3010 bytes --]

Dear Guile hackers,

What nice work you are doing!

For those who don't know me, I'm a Guile developer who has been doing
other stuff for some time.

When trying to use guile 2 for logic programming I discovered that the
slib interface is again broken (and has been for quite some time).
This easily happens because it is a very fragile interface.  The way
this is supposed to be used (and as documented in the manual), one
does a

  (use-modules (ice-9 slib))

and can then do

  (require 'modular)

etc.

The module (ice-9 slib) forms a kind of sandbox so that all new
definitions that are imported through "require" are loaded as local
bindings in the (ice-9 slib) module and are exported through the
public interface of (ice-9 slib).

The implementation of the interface has two sides.  One, the file
ice-9/slib.scm, is owned by Guile.  The other, slib/guile.init, is
owned by slib.  slib has such .init files for some common scheme
implementations but I early on noticed that that the guile.init file
is not really maintained.  I decided that it would be more robust if
slib.scm incorporated most of the interface so that it would be easy
to update it as Guile changed.  But of course slib also changed and at
some point others felt that guile.init should contain most of the
interface and the bulk of slib.scm was moved there.  As we have seen,
this didn't make things much better.

I'll let you ponder on how to handle the fundamental problems with
this interface, but, as a Guile user, I think it would be nice if the
interface works as written in the manual.  Attached to this email
you'll find two patches.  The patch to slib.scm copies a snippet of
code from guile.init so that they agree with eachother and with the
Guile reference manual on how to find slib in the filesystem.  This
patch for example makes SCHEME_LIBRARY_PATH work as described.

I've tried to write the patch to guile.init so that it can play well
with older Guile versions, but we should test this.  In order to make
it work with Guile 2, though, I had to introduce a new syntax binding
syntax-toplevel?.  Given a syntax object (as available within a
syntax-case transformer), it decides if the object originates from top
level context.  It is used, as in the old memoizing macro transformer,
to choose whether to define-public or just define.

*But*, the proper implementation of syntax-toplevel? requires
modification of psyntax.scm and adding it to the (system syntax)
module.  I didn't want to do this until I've had your comments, so the
present patch has its own syntax-object accessors (which breaks
abstraction and is therefore not a real solution).  I should also say
that I have not yet fixed the slib interface to the new Guile uniform
arrays, so there's a lot of slib functionality which won't yet work.

Comments?  Can I add syntax-toplevel? to psyntax.scm and (system
syntax)?  Do you think it is reasonable to submit something along the
line of guile.init.diff to slib guile.init?

Best regards,
Mikael Djurfeldt

[-- Attachment #2: slib.scm.diff --]
[-- Type: application/octet-stream, Size: 1151 bytes --]

--- ice-9/slib.scm.dpkg-dist	2012-03-18 20:16:21.000000000 +0100
+++ ice-9/slib.scm	2012-10-15 23:25:01.675171256 +0200
@@ -33,7 +33,24 @@
 
 \f
 ;; Initialize SLIB.
-(load-from-path "slib/guile.init")
+(define library-vicinity
+  (let ((library-path
+	 (or
+	  ;; Use this getenv if your implementation supports it.
+	  (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH"))
+	  ;; Rob Browning sent this; I'm not sure its a good idea.
+          ;; See if we can find slib/guile.init (cf. implementation-vicinity).
+          (let ((path (%search-load-path "slib/guile.init")))
+            (and path (substring path 0 (- (string-length path) 10))))
+	  ;; Use this path if your scheme does not support GETENV
+	  ;; or if SCHEME_LIBRARY_PATH is not set.
+;; Changed from /usr/lib/slib to /usr/share/slib by tb@debian.org for
+;; Debian packaging.
+;;	  "/usr/lib/slib/"
+	  "/usr/share/slib/")))
+    (lambda () library-path)))
+
+(primitive-load (in-vicinity (library-vicinity) "guile.init"))
 
 ;; SLIB redefines a few core symbols based on their default definition.
 ;; Thus, we only replace them at this point so that their previous definition

[-- Attachment #3: guile.init.diff --]
[-- Type: application/octet-stream, Size: 8326 bytes --]

--- slib/guile.init.dpkg-dist	2010-05-06 08:20:58.000000000 +0200
+++ slib/guile.init	2012-10-22 00:06:21.457707670 +0200
@@ -7,11 +7,29 @@
     (define-module (ice-9 slib)))	; :no-backtrace
 (define slib-module (current-module))
 
-(define base:define define)
-(define define
-  (procedure->memoizing-macro
-   (lambda (exp env)
-     (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp)))))
+;;(define base:define define)
+;; The following line should work for all version >= 1.6
+(local-define '(base:define) (local-ref '(define)))
+(cond-expand
+ (guile-2
+  (define-syntax define
+    (let* ((syntax-object-wrap (lambda (s) (vector-ref s 2)))
+	   (wrap-subst cdr)
+	   (syntax-toplevel?
+	    (lambda (s)
+	      (null? (cdr (wrap-subst (syntax-object-wrap s)))))))
+      (lambda (x)
+	(syntax-case x ()
+	  ((_ f0 f1 ...)
+	   (syntax-toplevel? #'f0)
+	   (syntax (define-public f0 f1 ...)))
+	  ((_ f0 f1 ...)
+	   (syntax (base:define f0 f1 ...))))))))
+ (guile
+  (define define
+    (procedure->memoizing-macro
+     (lambda (exp env)
+       (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp)))))))
 
 ;;; Hack to make syncase macros work in the slib module
 (if (nested-ref the-root-module '(app modules ice-9 syncase))
@@ -274,12 +292,13 @@
 ;; calling waitpid with WUNTRACED, but allow for it anyway, just in
 ;; case.
 (define system
-      (let ((guile-core-system system))
+      (let ((guile-core-system (nested-ref the-root-module '(system))))
 	(lambda (str)
 	  (define st (guile-core-system str))
 	  (or (status:exit-val st)
 	      (+ 128 (or (status:term-sig st)
 			 (status:stop-sig st)))))))
+
 ;; This has to be done after the definition so that the original
 ;; binding will still be visible during the definition.
 (if (string>=? (scheme-implementation-version) "1.8")
@@ -305,7 +324,7 @@
        (re-export write-line)))
 
 (define delete-file
-      (let ((guile-core-delete-file delete-file))
+      (let ((guile-core-delete-file (nested-ref the-root-module '(delete-file))))
 	(lambda (filename)
 	  (catch 'system-error
 		 (lambda () (guile-core-delete-file filename) #t)
@@ -325,7 +344,7 @@
 (define (make-exchanger obj)
   (lambda (rep) (let ((old obj)) (set! obj rep) old)))
 (define open-file
-      (let ((guile-core-open-file open-file))
+      (let ((guile-core-open-file (nested-ref the-root-module '(open-file))))
 	(lambda (filename modes)
 	  (guile-core-open-file filename
 				(if (symbol? modes)
@@ -346,17 +365,16 @@
     (for-each close-port ports)
     ans))
 
-(if (not (defined? 'browse-url))
-    ;; Nothing special to do for this, so straight from
-    ;; Template.scm.  Maybe "sensible-browser" for a debian
-    ;; system would be worth trying too (and would be good on a
-    ;; tty).
-    (define (browse-url url)
-      (define (try cmd end) (zero? (system (string-append cmd url end))))
-      (or (try "netscape-remote -remote 'openURL(" ")'")
-	  (try "netscape -remote 'openURL(" ")'")
-	  (try "netscape '" "'&")
-	  (try "netscape '" "'"))))
+;; Nothing special to do for this, so straight from
+;; Template.scm.  Maybe "sensible-browser" for a debian
+;; system would be worth trying too (and would be good on a
+;; tty).
+(define (browse-url url)
+  (define (try cmd end) (zero? (system (string-append cmd url end))))
+  (or (try "netscape-remote -remote 'openURL(" ")'")
+      (try "netscape -remote 'openURL(" ")'")
+      (try "netscape '" "'&")
+      (try "netscape '" "'")))
 
 ;;; "rationalize" adjunct procedures.
 ;;(define (find-ratio x e)
@@ -369,7 +387,7 @@
 ;;; be returned by CHAR->INTEGER.
 ;; In Guile-1.8.0: (string>? (string #\000) (string #\200)) ==> #t
 (if (string=? (version) "1.8.0")
-    (define char-code-limit 128))
+    (set! char-code-limit 128))
 
 ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
 ;;(define most-positive-fixnum #x0FFFFFFF)
@@ -386,49 +404,55 @@
 ;;; return if exiting not supported.
 (define slib:exit quit)
 
+(define slib:load #f)
+(define slib:load-from-path #f)
+(define read #f)
 (cond ((string>=? (scheme-implementation-version) "1.8")
-       (define (slib:load-helper loader)
-	 (lambda (name)
-	   (save-module-excursion
-	    (lambda ()
-	      (set-current-module slib-module)
-	      (let ((errinfo (catch 'system-error
-				    (lambda () (loader name) #f)
-				    (lambda args args))))
-		(if (and errinfo
-			 (catch 'system-error
-				(lambda () (loader (string-append name ".scm")) #f)
-				(lambda args args)))
-		    (apply throw errinfo)))))))
-       (define slib:load (slib:load-helper load))
-       (define slib:load-from-path (slib:load-helper load-from-path))
+       (let ((slib:load-helper
+	      (lambda (loader)
+		(lambda (name)
+		  (save-module-excursion
+		   (lambda ()
+		     (set-current-module slib-module)
+		     (let ((errinfo (catch 'system-error
+					   (lambda () (loader name) #f)
+					   (lambda args args))))
+		       (if (and errinfo
+				(catch 'system-error
+				       (lambda () (loader (string-append name ".scm")) #f)
+				       (lambda args args)))
+			   (apply throw errinfo)))))))))
+	 (set! slib:load (slib:load-helper load))
+	 (set! slib:load-from-path (slib:load-helper load-from-path)))
+       (set! read (nested-ref the-root-module '(read)))
        )
       (else
        ;;Here for backward compatability
-       (define scheme-file-suffix
-	 (let ((suffix (case (software-type)
-			 ((nosve) "_scm")
-			 (else ".scm"))))
-	   (lambda () suffix)))
-
-       (define (guile:wrap-case-insensitive proc)
-	 (lambda args
-	   (save-module-excursion
-	    (lambda ()
-	      (set-current-module slib-module)
-	      (let ((old (read-options)))
-		(dynamic-wind
-		    (lambda () (read-enable 'case-insensitive))
-		    (lambda () (apply proc args))
-		    (lambda () (read-options old))))))))
-
-       (define read (guile:wrap-case-insensitive read))
-
-       (define slib:load
-	 (let ((load-file (guile:wrap-case-insensitive load)))
-	   (lambda (<pathname>)
-	     (load-file (string-append <pathname> (scheme-file-suffix))))))
-       ))
+       (let ((scheme-file-suffix
+	      (let ((suffix (case (software-type)
+			      ((nosve) "_scm")
+			      (else ".scm"))))
+		(lambda () suffix)))
+	     (guile:wrap-case-insensitive
+	       (lambda (proc)
+		 (lambda args
+		   (save-module-excursion
+		    (lambda ()
+		      (set-current-module slib-module)
+		      (let ((old (read-options)))
+			(dynamic-wind
+			    (lambda () (read-enable 'case-insensitive))
+			    (lambda () (apply proc args))
+			    (lambda () (read-options old))))))))))
+
+	 (set! read
+	       (guile:wrap-case-insensitive
+		(nested-ref the-root-module '(read))))
+
+	 (set! slib:load
+	       (let ((load-file (guile:wrap-case-insensitive load)))
+		 (lambda (<pathname>)
+		   (load-file (string-append <pathname> (scheme-file-suffix)))))))))
 
 ;;;(SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
 ;;;suffix all the module files in SLIB have.  See feature 'SOURCE.
@@ -645,20 +669,24 @@
 		  (require 'object->string)
 		  (set! seed (object->limited-string seed 50)))))
     (seed->random-state seed)))
-(if (not (defined? 'random:chunk))
-    (define (random:chunk sta) (random 256 sta)))
+;;(if (not (defined? 'random:chunk))
+(define (random:chunk sta) (random 256 sta))
 
 ;;; workaround for Guile 1.6.7 bug
-(cond ((or (array? 'guile) (array? '(1 6 7)))
-       (define array?
-	 (let ((old-array? array?))
-	   (lambda (obj)
-	     (and (old-array? obj)
-		  (not (or (list? obj)
-			   (symbol? obj)
-			   (record? obj)))))))
-       (if (string>=? (scheme-implementation-version) "1.8")
-	   (module-replace! (current-module) '(array?)))))
+(base:define array? #f)
+(let ((guile-core-array? (nested-ref the-root-module '(array?))))
+  (cond ((or (guile-core-array? 'guile) (guile-core-array? '(1 6 7)))
+	 (set! array?
+	       (lambda (obj)
+		 (and (guile-core-array? obj)
+		      (not (or (list? obj)
+			       (symbol? obj)
+			       (record? obj))))))
+	 (export array?)
+	 (if (string>=? (scheme-implementation-version) "1.8")
+	     (module-replace! (current-module) '(array?))))
+	(else
+	 (set! array? guile-core-array?))))
 
 ;;; Support for older versions of Scheme.  Not enough code for its own file.
 ;;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))

^ permalink raw reply	[flat|nested] 13+ messages in thread

end of thread, other threads:[~2013-01-21 19:04 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-10-21 23:11 Fixing the slib mess Mikael Djurfeldt
2012-10-22 18:31 ` Stefan Israelsson Tampe
2012-10-22 19:11   ` Mikael Djurfeldt
2012-10-22 19:33     ` Stefan Israelsson Tampe
2012-10-22 20:00 ` Mikael Djurfeldt
2012-10-22 21:51 ` Mark H Weaver
2012-10-23  8:23   ` Mikael Djurfeldt
2012-10-23 18:01     ` Mark H Weaver
2012-10-23 22:23       ` Mikael Djurfeldt
2012-11-01  5:25         ` Mark H Weaver
2013-01-21 17:58 ` Andy Wingo
2013-01-21 18:09   ` Mikael Djurfeldt
2013-01-21 19:04     ` Andy Wingo

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).