summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-09-25 17:17:02 +0200
committerAndy Wingo <wingo@pobox.com>2008-09-25 17:17:02 +0200
commit99b1dd09ccba248261b679657519e6a5b2b76560 (patch)
tree9f3860bcbfa2682c42a8773744cf3fe0d9c39f9d
parent7024b583294f2f3db19608510603d162fa1c6cb7 (diff)
downloadguile-99b1dd09ccba248261b679657519e6a5b2b76560.tar.gz
further compilation fixes -- all files compile fine now
* ice-9/runq.scm (strip-sequence): Remove use of obtuse guile `define' extension. * ice-9/boot-9.scm (while): Redefine so as not to unquote in a procedure. Less hygienic. Perhaps we should switch to syncase at some point. * ice-9/session.scm (help): Redefine as a normal macro, so that it can be compiled. Not very useful though -- further effort should go into (system repl ...). (system-module): Removed, it didn't work, and is not useful as far as I can tell. * ice-9/string-fun.scm (string-prefix-predicate): Remove guile define extension usage. Compilation also fixed by `while' compilation fix. * ice-9/threads.scm (par-mapper): Remove guile define extension usage.
-rw-r--r--ice-9/boot-9.scm24
-rw-r--r--ice-9/runq.scm15
-rw-r--r--ice-9/session.scm129
-rw-r--r--ice-9/string-fun.scm7
-rw-r--r--ice-9/threads.scm13
5 files changed, 88 insertions, 100 deletions
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index bdf7d409d..daf8e49b8 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -2730,18 +2730,18 @@ module '(ice-9 q) '(make-q q-length))}."
;; This is probably a bug in syncase.
;;
(define-macro (while cond . body)
- (define (while-helper proc)
- (do ((key (make-symbol "while-key")))
- ((catch key
- (lambda ()
- (proc (lambda () (throw key #t))
- (lambda () (throw key #f))))
- (lambda (key arg) arg)))))
- `(,while-helper (,lambda (break continue)
- (do ()
- ((,not ,cond))
- ,@body)
- #t)))
+ (let ((key (make-symbol "while-key")))
+ `(do ()
+ ((catch ',key
+ (lambda ()
+ (let ((break (lambda () (throw ',key #t)))
+ (continue (lambda () (throw ',key #f))))
+ (do ()
+ ((not ,cond))
+ ,@body)
+ #t))
+ (lambda (key arg)
+ arg))))))
diff --git a/ice-9/runq.scm b/ice-9/runq.scm
index 6ac4e5783..eb1e2203f 100644
--- a/ice-9/runq.scm
+++ b/ice-9/runq.scm
@@ -216,13 +216,14 @@
;;;
;;; Returns a new strip which is the concatenation of the argument strips.
;;;
-(define ((strip-sequence . strips))
- (let loop ((st (let ((a strips)) (set! strips #f) a)))
- (and (not (null? st))
- (let ((then ((car st))))
- (if then
- (lambda () (loop (cons then (cdr st))))
- (lambda () (loop (cdr st))))))))
+(define (strip-sequence . strips)
+ (lambda ()
+ (let loop ((st (let ((a strips)) (set! strips #f) a)))
+ (and (not (null? st))
+ (let ((then ((car st))))
+ (if then
+ (lambda () (loop (cons then (cdr st))))
+ (lambda () (loop (cdr st)))))))))
;;;;
diff --git a/ice-9/session.scm b/ice-9/session.scm
index 1c9f48016..25cd6e8dc 100644
--- a/ice-9/session.scm
+++ b/ice-9/session.scm
@@ -22,73 +22,71 @@
:use-module (ice-9 rdelim)
:export (help apropos apropos-internal apropos-fold
apropos-fold-accessible apropos-fold-exported apropos-fold-all
- source arity system-module))
+ source arity))
;;; Documentation
;;;
-(define help
- (procedure->syntax
- (lambda (exp env)
- "(help [NAME])
+(define-macro (help . exp)
+ "(help [NAME])
Prints useful information. Try `(help)'."
- (cond ((not (= (length exp) 2))
- (help-usage))
- ((not (provided? 'regex))
- (display "`help' depends on the `regex' feature.
+ (cond ((not (= (length exp) 1))
+ (help-usage))
+ ((not (provided? 'regex))
+ (display "`help' depends on the `regex' feature.
You don't seem to have regular expressions installed.\n"))
+ (else
+ (let ((name (car exp))
+ (not-found (lambda (type x)
+ (simple-format #t "No ~A found for ~A\n"
+ type x))))
+ (cond
+
+ ;; SYMBOL
+ ((symbol? name)
+ (help-doc name
+ (simple-format
+ #f "^~A$"
+ (regexp-quote (symbol->string name)))))
+
+ ;; "STRING"
+ ((string? name)
+ (help-doc name name))
+
+ ;; (unquote SYMBOL)
+ ((and (list? name)
+ (= (length name) 2)
+ (eq? (car name) 'unquote))
+ (cond ((object-documentation
+ (eval (cadr name) (current-module)))
+ => write-line)
+ (else (not-found 'documentation (cadr name)))))
+
+ ;; (quote SYMBOL)
+ ((and (list? name)
+ (= (length name) 2)
+ (eq? (car name) 'quote)
+ (symbol? (cadr name)))
+ (cond ((search-documentation-files (cadr name))
+ => write-line)
+ (else (not-found 'documentation (cadr name)))))
+
+ ;; (SYM1 SYM2 ...)
+ ((and (list? name)
+ (and-map symbol? name)
+ (not (null? name))
+ (not (eq? (car name) 'quote)))
+ (cond ((module-commentary name)
+ => (lambda (doc)
+ (display name) (write-line " commentary:")
+ (write-line doc)))
+ (else (not-found 'commentary name))))
+
+ ;; unrecognized
(else
- (let ((name (cadr exp))
- (not-found (lambda (type x)
- (simple-format #t "No ~A found for ~A\n"
- type x))))
- (cond
-
- ;; SYMBOL
- ((symbol? name)
- (help-doc name
- (simple-format
- #f "^~A$"
- (regexp-quote (symbol->string name)))))
-
- ;; "STRING"
- ((string? name)
- (help-doc name name))
-
- ;; (unquote SYMBOL)
- ((and (list? name)
- (= (length name) 2)
- (eq? (car name) 'unquote))
- (cond ((object-documentation
- (local-eval (cadr name) env))
- => write-line)
- (else (not-found 'documentation (cadr name)))))
-
- ;; (quote SYMBOL)
- ((and (list? name)
- (= (length name) 2)
- (eq? (car name) 'quote)
- (symbol? (cadr name)))
- (cond ((search-documentation-files (cadr name))
- => write-line)
- (else (not-found 'documentation (cadr name)))))
-
- ;; (SYM1 SYM2 ...)
- ((and (list? name)
- (and-map symbol? name)
- (not (null? name))
- (not (eq? (car name) 'quote)))
- (cond ((module-commentary name)
- => (lambda (doc)
- (display name) (write-line " commentary:")
- (write-line doc)))
- (else (not-found 'commentary name))))
-
- ;; unrecognized
- (else
- (help-usage)))
- *unspecified*))))))
+ (help-usage)))
+ '(begin)))))
(define (module-filename name) ; fixme: better way? / done elsewhere?
(let* ((name (map symbol->string name))
@@ -458,17 +456,4 @@ It is an image under the mapping EXTRACT."
(display #\'))))))))
(display ".\n"))
-(define system-module
- (procedure->syntax
- (lambda (exp env)
- (let* ((m (nested-ref the-root-module
- (append '(app modules) (cadr exp)))))
- (if (not m)
- (error "Couldn't find any module named" (cadr exp)))
- (let ((s (not (procedure-property (module-eval-closure m)
- 'system-module))))
- (set-system-module! m s)
- (string-append "Module " (symbol->string (module-name m))
- " is now a " (if s "system" "user") " module."))))))
-
;;; session.scm ends here
diff --git a/ice-9/string-fun.scm b/ice-9/string-fun.scm
index 590a7d2a4..d8ba21f75 100644
--- a/ice-9/string-fun.scm
+++ b/ice-9/string-fun.scm
@@ -197,9 +197,10 @@
;;; (define-public string-prefix=? (string-prefix-predicate string=?))
;;;
-(define ((string-prefix-predicate pred?) prefix str)
- (and (<= (string-length prefix) (string-length str))
- (pred? prefix (substring str 0 (string-length prefix)))))
+(define (string-prefix-predicate pred?)
+ (lambda (prefix str)
+ (and (<= (string-length prefix) (string-length str))
+ (pred? prefix (substring str 0 (string-length prefix))))))
(define string-prefix=? (string-prefix-predicate string=?))
diff --git a/ice-9/threads.scm b/ice-9/threads.scm
index cdabb2417..bd0f7b745 100644
--- a/ice-9/threads.scm
+++ b/ice-9/threads.scm
@@ -47,12 +47,13 @@
-(define ((par-mapper mapper) proc . arglists)
- (mapper join-thread
- (apply map
- (lambda args
- (begin-thread (apply proc args)))
- arglists)))
+(define (par-mapper mapper)
+ (lambda (proc . arglists)
+ (mapper join-thread
+ (apply map
+ (lambda args
+ (begin-thread (apply proc args)))
+ arglists))))
(define par-map (par-mapper map))
(define par-for-each (par-mapper for-each))