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))