mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-09 10:50:27 +02:00
Code Activity

Surround commentary w/ standard markers; nfc.

Browse source
This commit is contained in:
Thien-Thi Nguyen 2001-04-28 19:07:38 +00:00
parent f32e992f53
commit 20edfbbdb5
1 changed files with 53 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

101
ice-9/boot-9.scm
View file

@ -1,31 +1,35 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or modify ;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by ;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option) ;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version. ;;;; any later version.
;;;; ;;;;
;;;; This program is distributed in the hope that it will be useful, ;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details. ;;;; GNU General Public License for more details.
;;;; ;;;;
;;;; You should have received a copy of the GNU General Public License ;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to ;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA ;;;; Boston, MA 02111-1307 USA
;;;; ;;;;
;;; Commentary:
;;; This file is the first thing loaded into Guile. It adds many mundane ;;; This file is the first thing loaded into Guile. It adds many mundane
;;; definitions and a few that are interesting. ;;; definitions and a few that are interesting.
;;; ;;;
;;; The module system (hence the hierarchical namespace) are defined in this ;;; The module system (hence the hierarchical namespace) are defined in this
;;; file. ;;; file.
;;; ;;;
;;; Code:
;;; {Features} ;;; {Features}
;; ;;
@ -98,12 +102,12 @@
;;; apply-to-args is functionally redunant with apply and, worse, ;;; apply-to-args is functionally redunant with apply and, worse,
;;; is less general than apply since it only takes two arguments. ;;; is less general than apply since it only takes two arguments.
;;; ;;;
;;; On the other hand, apply-to-args is a syntacticly convenient way to ;;; On the other hand, apply-to-args is a syntacticly convenient way to
;;; perform binding in many circumstances when the "let" family of ;;; perform binding in many circumstances when the "let" family of
;;; of forms don't cut it. E.g.: ;;; of forms don't cut it. E.g.:
;;; ;;;
;;; (apply-to-args (return-3d-mouse-coords) ;;; (apply-to-args (return-3d-mouse-coords)
;;; (lambda (x y z) ;;; (lambda (x y z)
;;; ...)) ;;; ...))
;;; ;;;
@ -250,7 +254,7 @@
new-port)) new-port))
;; 0: type-name, 1: fields ;; 0: type-name, 1: fields
(define record-type-vtable (define record-type-vtable
(make-vtable-vtable "prpr" 0 (make-vtable-vtable "prpr" 0
(lambda (s p) (lambda (s p)
(cond ((eq? s record-type-vtable) (cond ((eq? s record-type-vtable)
@ -395,7 +399,7 @@
;; Apply f to successive elements of l until exhaustion or f returns #f. ;; Apply f to successive elements of l until exhaustion or f returns #f.
;; If returning early, return #f. Otherwise, return the last value returned ;; If returning early, return #f. Otherwise, return the last value returned
;; by f. If f has never been called because l is empty, return #t. ;; by f. If f has never been called because l is empty, return #t.
;; ;;
(define (and-map f lst) (define (and-map f lst)
(let loop ((result #t) (let loop ((result #t)
(l lst)) (l lst))
@ -534,7 +538,7 @@
(if (pair? maybe-fd) (if (pair? maybe-fd)
(set-port-revealed! port 1)) (set-port-revealed! port 1))
port)) port))
(define (dup->inport port/fd . maybe-fd) (define (dup->inport port/fd . maybe-fd)
(apply dup->port port/fd "r" maybe-fd)) (apply dup->port port/fd "r" maybe-fd))
@ -834,9 +838,9 @@
(display help) (display help)
(newline)))) (newline))))
kw-desc)) kw-desc))
(define (transform-usage-lambda cases) (define (transform-usage-lambda cases)
(let* ((raw-usage (delq! 'else (map car cases))) (let* ((raw-usage (delq! 'else (map car cases)))
(usage-sans-specials (map (lambda (x) (usage-sans-specials (map (lambda (x)
@ -1062,7 +1066,7 @@
;;; ;;;
;; module-search fn m ;; module-search fn m
;; ;;
;; return the first non-#f result of FN applied to M and then to ;; return the first non-#f result of FN applied to M and then to
;; the modules in the uses of m, and so on recursively. If all applications ;; the modules in the uses of m, and so on recursively. If all applications
;; return #f, then so does this function. ;; return #f, then so does this function.
@ -1101,7 +1105,7 @@
;;; {Is a symbol interned in a module?} ;;; {Is a symbol interned in a module?}
;;; ;;;
;;; Symbol S in Module M is interned if S occurs in ;;; Symbol S in Module M is interned if S occurs in
;;; of S in M has been set to some well-defined value. ;;; of S in M has been set to some well-defined value.
;;; ;;;
;;; It is possible to intern a symbol in a module without providing ;;; It is possible to intern a symbol in a module without providing
@ -1127,7 +1131,7 @@
((if (symbol? key) hashq-remove! hash-remove!) ob key)) ((if (symbol? key) hashq-remove! hash-remove!) ob key))
;; module-symbol-locally-interned? module symbol ;; module-symbol-locally-interned? module symbol
;; ;;
;; is a symbol interned (not neccessarily defined) locally in a given module ;; is a symbol interned (not neccessarily defined) locally in a given module
;; or its uses? Interned symbols shadow inherited bindings even if ;; or its uses? Interned symbols shadow inherited bindings even if
;; they are not themselves bound to a defined value. ;; they are not themselves bound to a defined value.
@ -1136,7 +1140,7 @@
(not (not (module-obarray-get-handle (module-obarray m) v)))) (not (not (module-obarray-get-handle (module-obarray m) v))))
;; module-symbol-interned? module symbol ;; module-symbol-interned? module symbol
;; ;;
;; is a symbol interned (not neccessarily defined) anywhere in a given module ;; is a symbol interned (not neccessarily defined) anywhere in a given module
;; or its uses? Interned symbols shadow inherited bindings even if ;; or its uses? Interned symbols shadow inherited bindings even if
;; they are not themselves bound to a defined value. ;; they are not themselves bound to a defined value.
@ -1174,8 +1178,8 @@
;)) ;))
;; module-variable module symbol ;; module-variable module symbol
;; ;;
;; like module-local-variable, except search the uses in the ;; like module-local-variable, except search the uses in the
;; case V is not found in M. ;; case V is not found in M.
;; ;;
;; NOTE: This function is superseded with C code (see modules.c) ;; NOTE: This function is superseded with C code (see modules.c)
@ -1192,7 +1196,7 @@
;;; ;;;
;; module-symbol-binding module symbol opt-value ;; module-symbol-binding module symbol opt-value
;; ;;
;; return the binding of a variable specified by name within ;; return the binding of a variable specified by name within
;; a given module, signalling an error if the variable is unbound. ;; a given module, signalling an error if the variable is unbound.
;; If the OPT-VALUE is passed, then instead of signalling an error, ;; If the OPT-VALUE is passed, then instead of signalling an error,
@ -1207,7 +1211,7 @@
(error "Locally unbound variable." v))))) (error "Locally unbound variable." v)))))
;; module-symbol-binding module symbol opt-value ;; module-symbol-binding module symbol opt-value
;; ;;
;; return the binding of a variable specified by name within ;; return the binding of a variable specified by name within
;; a given module, signalling an error if the variable is unbound. ;; a given module, signalling an error if the variable is unbound.
;; If the OPT-VALUE is passed, then instead of signalling an error, ;; If the OPT-VALUE is passed, then instead of signalling an error,
@ -1229,7 +1233,7 @@
;; module-make-local-var! module symbol ;; module-make-local-var! module symbol
;; ;;
;; ensure a variable for V in the local namespace of M. ;; ensure a variable for V in the local namespace of M.
;; If no variable was already there, then create a new and uninitialzied ;; If no variable was already there, then create a new and uninitialzied
;; variable. ;; variable.
@ -1249,7 +1253,7 @@
answer)))) answer))))
;; module-add! module symbol var ;; module-add! module symbol var
;; ;;
;; ensure a particular variable for V in the local namespace of M. ;; ensure a particular variable for V in the local namespace of M.
;; ;;
(define (module-add! m v var) (define (module-add! m v var)
@ -1258,8 +1262,8 @@
(module-obarray-set! (module-obarray m) v var) (module-obarray-set! (module-obarray m) v var)
(module-modified m)) (module-modified m))
;; module-remove! ;; module-remove!
;; ;;
;; make sure that a symbol is undefined in the local namespace of M. ;; make sure that a symbol is undefined in the local namespace of M.
;; ;;
(define (module-remove! m v) (define (module-remove! m v)
@ -1271,7 +1275,7 @@
(module-modified m)) (module-modified m))
;; MODULE-FOR-EACH -- exported ;; MODULE-FOR-EACH -- exported
;; ;;
;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE). ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
;; ;;
(define (module-for-each proc module) (define (module-for-each proc module)
@ -1304,9 +1308,9 @@
;;; {Low Level Bootstrapping} ;;; {Low Level Bootstrapping}
;;; ;;;
;; make-root-module ;; make-root-module
;; A root module uses the symhash table (the system's privileged ;; A root module uses the symhash table (the system's privileged
;; obarray). Being inside a root module is like using SCM without ;; obarray). Being inside a root module is like using SCM without
;; any module system. ;; any module system.
;; ;;
@ -1324,7 +1328,7 @@
(make-module 1019 '() root-module-closure)) (make-module 1019 '() root-module-closure))
;; make-scm-module ;; make-scm-module
;; An scm module is a module into which the lazy binder copies ;; An scm module is a module into which the lazy binder copies
;; variable bindings from the system symhash table. The mapping is ;; variable bindings from the system symhash table. The mapping is
@ -1383,7 +1387,7 @@
;; Returns the value of a variable called NAME in MODULE or any of its ;; Returns the value of a variable called NAME in MODULE or any of its
;; used modules. If there is no such variable, then if the optional third ;; used modules. If there is no such variable, then if the optional third
;; argument DEFAULT is present, it is returned; otherwise an error is signaled. ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
;; ;;
(define (module-ref module name . rest) (define (module-ref module name . rest)
(let ((variable (module-variable module name))) (let ((variable (module-variable module name)))
(if (and variable (variable-bound? variable)) (if (and variable (variable-bound? variable))
@ -1397,7 +1401,7 @@
;; ;;
;; Sets the variable called NAME in MODULE (or in a module that MODULE uses) ;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
;; to VALUE; if there is no such variable, an error is signaled. ;; to VALUE; if there is no such variable, an error is signaled.
;; ;;
(define (module-set! module name value) (define (module-set! module name value)
(let ((variable (module-variable module name))) (let ((variable (module-variable module name)))
(if variable (if variable
@ -1408,7 +1412,7 @@
;; ;;
;; Sets the variable called NAME in MODULE to VALUE; if there is no such ;; Sets the variable called NAME in MODULE to VALUE; if there is no such
;; variable, it is added first. ;; variable, it is added first.
;; ;;
(define (module-define! module name value) (define (module-define! module name value)
(let ((variable (module-local-variable module name))) (let ((variable (module-local-variable module name)))
(if variable (if variable
@ -1429,7 +1433,7 @@
;; MODULE-USE! module interface ;; MODULE-USE! module interface
;; ;;
;; Add INTERFACE to the list of interfaces used by MODULE. ;; Add INTERFACE to the list of interfaces used by MODULE.
;; ;;
(define (module-use! module interface) (define (module-use! module interface)
(set-module-uses! module (set-module-uses! module
(cons interface (delq! interface (module-uses module)))) (cons interface (delq! interface (module-uses module))))
@ -1447,7 +1451,7 @@
;;; modules. ;;; modules.
;;; ;;;
;;; (nested-ref some-root-module '(foo bar baz)) ;;; (nested-ref some-root-module '(foo bar baz))
;;; => <value of a variable named baz in the module bound to bar in ;;; => <value of a variable named baz in the module bound to bar in
;;; the module bound to foo in some-root-module> ;;; the module bound to foo in some-root-module>
;;; ;;;
;;; ;;;
@ -1566,7 +1570,7 @@
(try-load-module name)) (try-load-module name))
;; Get/create it. ;; Get/create it.
(make-modules-in (current-module) full-name)))))) (make-modules-in (current-module) full-name))))))
(define (beautify-user-module! module) (define (beautify-user-module! module)
(let ((interface (module-public-interface module))) (let ((interface (module-public-interface module)))
(if (or (not interface) (if (or (not interface)
@ -1675,7 +1679,7 @@
(loop (cddr kws) (loop (cddr kws)
reversed-interfaces reversed-interfaces
(append (cadr kws) exports))) (append (cadr kws) exports)))
(else (else
(error "unrecognized defmodule argument" kws)))))) (error "unrecognized defmodule argument" kws))))))
(set-current-module module) (set-current-module module)
module)) module))
@ -1758,9 +1762,9 @@
;; scm_init_ice_9_gtcltk_module ;; scm_init_ice_9_gtcltk_module
;; ;;
;; This is your `module init' function. It should call ;; This is your `module init' function. It should call
;; ;;
;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk); ;; scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);
;; ;;
;; "ice-9 gtcltk" is the C version of the module name. Slashes are ;; "ice-9 gtcltk" is the C version of the module name. Slashes are
;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is ;; replaced by spaces, the rest is untouched. `scm_init_gtcltk' is
;; the real init function that executes the usual initializations ;; the real init function that executes the usual initializations
@ -1901,7 +1905,7 @@
(string-append libname ".la")))) (string-append libname ".la"))))
(and (file-exists? libtool-filename) (and (file-exists? libtool-filename)
libtool-filename))) libtool-filename)))
(define (try-using-sharlib-name libdir libname) (define (try-using-sharlib-name libdir libname)
(in-vicinity libdir (string-append libname ".so"))) (in-vicinity libdir (string-append libname ".so")))
@ -1959,7 +1963,7 @@
;; in. The only defined situation right now is `load-toplevel' which ;; in. The only defined situation right now is `load-toplevel' which
;; triggers for code evaluated at the top-level, for example from the ;; triggers for code evaluated at the top-level, for example from the
;; REPL or when loading a file. ;; REPL or when loading a file.
(define eval-case (define eval-case
(procedure->memoizing-macro (procedure->memoizing-macro
(lambda (exp env) (lambda (exp env)
@ -1968,7 +1972,7 @@
(define (syntax) (define (syntax)
(error "syntax error in eval-case")) (error "syntax error in eval-case"))
(let loop ((clauses (cdr exp))) (let loop ((clauses (cdr exp)))
(cond (cond
((null? clauses) ((null? clauses)
#f) #f)
((not (list? (car clauses))) ((not (list? (car clauses)))
@ -2207,7 +2211,7 @@
(let ((status #f) (let ((status #f)
(interactive #t)) (interactive #t))
(define (loop first) (define (loop first)
(let ((next (let ((next
(catch #t (catch #t
(lambda () (lambda ()
@ -2219,7 +2223,7 @@
(with-traps (with-traps
(lambda () (lambda ()
(first) (first)
;; This line is needed because mark ;; This line is needed because mark
;; doesn't do closures quite right. ;; doesn't do closures quite right.
;; Unreferenced locals should be ;; Unreferenced locals should be
@ -2232,7 +2236,7 @@
(lambda () (mask-signals)))) (lambda () (mask-signals))))
lazy-handler-dispatch)) lazy-handler-dispatch))
(lambda (key . args) (lambda (key . args)
(case key (case key
((quit) ((quit)
@ -2279,7 +2283,7 @@
(apply bad-throw key args)))))))))) (apply bad-throw key args))))))))))
(if next (loop next) status))) (if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg) (set! set-batch-mode?! (lambda (arg)
(cond (arg (cond (arg
(set! interactive #f) (set! interactive #f)
(restore-signals)) (restore-signals))
(#t (#t
@ -2458,7 +2462,7 @@
(primitive-eval sourc)))) (primitive-eval sourc))))
(run-hook after-eval-hook sourc) (run-hook after-eval-hook sourc)
val))) val)))
(-print (let ((maybe-print (lambda (result) (-print (let ((maybe-print (lambda (result)
(if (or scm-repl-print-unspecified (if (or scm-repl-print-unspecified
@ -2496,7 +2500,7 @@
-eval -eval
-print))) -print)))
(-quit status)))) (-quit status))))
;;; {IOTA functions: generating lists of numbers} ;;; {IOTA functions: generating lists of numbers}
@ -2693,7 +2697,7 @@
(lambda () (fluid-ref using-readline?)) (lambda () (fluid-ref using-readline?))
(lambda (v) (fluid-set! using-readline? v))))) (lambda (v) (fluid-set! using-readline? v)))))
(define (top-repl) (define (top-repl)
;; Load emacs interface support if emacs option is given. ;; Load emacs interface support if emacs option is given.
(if (and (module-defined? the-root-module 'use-emacs-interface) (if (and (module-defined? the-root-module 'use-emacs-interface)
@ -2701,7 +2705,7 @@
(load-emacs-interface)) (load-emacs-interface))
;; Place the user in the guile-user module. ;; Place the user in the guile-user module.
(process-define-module (process-define-module
'((guile-user) '((guile-user)
:use-module (guile) ;so that bindings will be checked here first :use-module (guile) ;so that bindings will be checked here first
:use-module (ice-9 session) :use-module (ice-9 session)
@ -2773,3 +2777,4 @@
(append! %load-path (cons "." '())) (append! %load-path (cons "." '()))
;;; boot-9.scm ends here