mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
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.
This commit is contained in:
Andy Wingo
parent
7024b58329
commit
99b1dd09cc
5 changed files with 88 additions and 100 deletions
|
|
@ -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))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))))))))
|
||||
|
||||
|
||||
;;;;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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=?))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue