/[guile]/guile/guile-core/ice-9/boot-9.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/boot-9.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.205 by mdj, Sun Jun 11 18:29:57 2000 UTC revision 1.205.2.1 by ttn, Mon Mar 4 18:58:54 2002 UTC
# Line 1  Line 1 
1  ;;; installed-scm-file  ;;; installed-scm-file
2    
3  ;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.  ;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
4  ;;;;  ;;;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; This program is free software; you can redistribute it and/or modify
6  ;;;; 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
7  ;;;; the Free Software Foundation; either version 2, or (at your option)  ;;;; the Free Software Foundation; either version 2, or (at your option)
8  ;;;; any later version.  ;;;; any later version.
9  ;;;;  ;;;;
10  ;;;; This program is distributed in the hope that it will be useful,  ;;;; This program is distributed in the hope that it will be useful,
11  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13  ;;;; GNU General Public License for more details.  ;;;; GNU General Public License for more details.
14  ;;;;  ;;;;
15  ;;;; You should have received a copy of the GNU General Public License  ;;;; You should have received a copy of the GNU General Public License
16  ;;;; along with this software; see the file COPYING.  If not, write to  ;;;; along with this software; see the file COPYING.  If not, write to
17  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18  ;;;; Boston, MA 02111-1307 USA  ;;;; Boston, MA 02111-1307 USA
19  ;;;;  ;;;;
20    
21    
22  ;;; 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
23  ;;; definitions and a few that are interesting.  ;;; definitions and a few that are interesting.
24  ;;;  ;;;
25  ;;; The module system (hence the hierarchical namespace) are defined in this  ;;; The module system (hence the hierarchical namespace) are defined in this
26  ;;; file.  ;;; file.
27  ;;;  ;;;
28    
# Line 98  Line 98 
98  ;;; apply-to-args is functionally redunant with apply and, worse,  ;;; apply-to-args is functionally redunant with apply and, worse,
99  ;;; is less general than apply since it only takes two arguments.  ;;; is less general than apply since it only takes two arguments.
100  ;;;  ;;;
101  ;;; 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
102  ;;; perform binding in many circumstances when the "let" family of  ;;; perform binding in many circumstances when the "let" family of
103  ;;; of forms don't cut it.  E.g.:  ;;; of forms don't cut it.  E.g.:
104  ;;;  ;;;
105  ;;;     (apply-to-args (return-3d-mouse-coords)  ;;;     (apply-to-args (return-3d-mouse-coords)
106  ;;;       (lambda (x y z)  ;;;       (lambda (x y z)
107  ;;;             ...))  ;;;             ...))
108  ;;;  ;;;
109    
# Line 213  Line 213 
213                 ((concat) (string-set! buf (+ nchars start) terminator)                 ((concat) (string-set! buf (+ nchars start) terminator)
214                           (+ nchars 1))                           (+ nchars 1))
215                 ((split) (cons nchars terminator))                 ((split) (cons nchars terminator))
216                 (else (error "unexpected handle-delim value: "                 (else (error "unexpected handle-delim value: "
217                              handle-delim))))))))                              handle-delim))))))))
218      
219  (define (read-delimited delims . args)  (define (read-delimited delims . args)
220    (let* ((port (if (pair? args)    (let* ((port (if (pair? args)
221                     (let ((pt (car args)))                     (let ((pt (car args)))
# Line 351  Line 351 
351        new-port))        new-port))
352    
353  ;; 0: type-name, 1: fields  ;; 0: type-name, 1: fields
354  (define record-type-vtable  (define record-type-vtable
355    (make-vtable-vtable "prpr" 0    (make-vtable-vtable "prpr" 0
356                        (lambda (s p)                        (lambda (s p)
357                          (cond ((eq? s record-type-vtable)                          (cond ((eq? s record-type-vtable)
# Line 529  Line 529 
529  ;; 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.
530  ;; If returning early, return #f.  Otherwise, return the last value returned  ;; If returning early, return #f.  Otherwise, return the last value returned
531  ;; 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.
532  ;;  ;;
533  (define (and-map f lst)  (define (and-map f lst)
534    (let loop ((result #t)    (let loop ((result #t)
535               (l lst))               (l lst))
# Line 668  Line 668 
668      (if (pair? maybe-fd)      (if (pair? maybe-fd)
669          (set-port-revealed! port 1))          (set-port-revealed! port 1))
670      port))      port))
671      
672  (define (dup->inport port/fd . maybe-fd)  (define (dup->inport port/fd . maybe-fd)
673    (apply dup->port port/fd "r" maybe-fd))    (apply dup->port port/fd "r" maybe-fd))
674    
# Line 793  Line 793 
793  (define expt  (define expt
794    (let ((integer-expt integer-expt))    (let ((integer-expt integer-expt))
795      (lambda (z1 z2)      (lambda (z1 z2)
796        (cond ((exact? z2)        (cond ((integer? z2)
797               (integer-expt z1 z2))               (if (>= z2 0)
798                     (integer-expt z1 z2)
799                     (/ 1 (integer-expt z1 (- z2)))))
800              ((and (real? z2) (real? z1) (>= z1 0))              ((and (real? z2) (real? z1) (>= z1 0))
801               ($expt z1 z2))               ($expt z1 z2))
802              (else              (else
# Line 966  Line 968 
968             (display help)             (display help)
969             (newline))))             (newline))))
970     kw-desc))     kw-desc))
                     
971    
972              
973    
974  (define (transform-usage-lambda cases)  (define (transform-usage-lambda cases)
975    (let* ((raw-usage (delq! 'else (map car cases)))    (let* ((raw-usage (delq! 'else (map car cases)))
976           (usage-sans-specials (map (lambda (x)           (usage-sans-specials (map (lambda (x)
# Line 1191  Line 1193 
1193  ;;;  ;;;
1194    
1195  ;; module-search fn m  ;; module-search fn m
1196  ;;  ;;
1197  ;; 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
1198  ;; 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
1199  ;; return #f, then so does this function.  ;; return #f, then so does this function.
# Line 1230  Line 1232 
1232    
1233  ;;; {Is a symbol interned in a module?}  ;;; {Is a symbol interned in a module?}
1234  ;;;  ;;;
1235  ;;; Symbol S in Module M is interned if S occurs in  ;;; Symbol S in Module M is interned if S occurs in
1236  ;;; of S in M has been set to some well-defined value.  ;;; of S in M has been set to some well-defined value.
1237  ;;;  ;;;
1238  ;;; It is possible to intern a symbol in a module without providing  ;;; It is possible to intern a symbol in a module without providing
# Line 1256  Line 1258 
1258    ((if (symbol? key) hashq-remove! hash-remove!) ob key))    ((if (symbol? key) hashq-remove! hash-remove!) ob key))
1259    
1260  ;; module-symbol-locally-interned? module symbol  ;; module-symbol-locally-interned? module symbol
1261  ;;  ;;
1262  ;; is a symbol interned (not neccessarily defined) locally in a given module  ;; is a symbol interned (not neccessarily defined) locally in a given module
1263  ;; or its uses?  Interned symbols shadow inherited bindings even if  ;; or its uses?  Interned symbols shadow inherited bindings even if
1264  ;; they are not themselves bound to a defined value.  ;; they are not themselves bound to a defined value.
# Line 1265  Line 1267 
1267    (not (not (module-obarray-get-handle (module-obarray m) v))))    (not (not (module-obarray-get-handle (module-obarray m) v))))
1268    
1269  ;; module-symbol-interned? module symbol  ;; module-symbol-interned? module symbol
1270  ;;  ;;
1271  ;; is a symbol interned (not neccessarily defined) anywhere in a given module  ;; is a symbol interned (not neccessarily defined) anywhere in a given module
1272  ;; or its uses?  Interned symbols shadow inherited bindings even if  ;; or its uses?  Interned symbols shadow inherited bindings even if
1273  ;; they are not themselves bound to a defined value.  ;; they are not themselves bound to a defined value.
# Line 1303  Line 1305 
1305  ;))  ;))
1306    
1307  ;; module-variable module symbol  ;; module-variable module symbol
1308  ;;  ;;
1309  ;; like module-local-variable, except search the uses in the  ;; like module-local-variable, except search the uses in the
1310  ;; case V is not found in M.  ;; case V is not found in M.
1311  ;;  ;;
1312  ;; NOTE: This function is superseded with C code (see modules.c)  ;; NOTE: This function is superseded with C code (see modules.c)
# Line 1321  Line 1323 
1323  ;;;  ;;;
1324    
1325  ;; module-symbol-binding module symbol opt-value  ;; module-symbol-binding module symbol opt-value
1326  ;;  ;;
1327  ;; return the binding of a variable specified by name within  ;; return the binding of a variable specified by name within
1328  ;; a given module, signalling an error if the variable is unbound.  ;; a given module, signalling an error if the variable is unbound.
1329  ;; If the OPT-VALUE is passed, then instead of signalling an error,  ;; If the OPT-VALUE is passed, then instead of signalling an error,
# Line 1336  Line 1338 
1338              (error "Locally unbound variable." v)))))              (error "Locally unbound variable." v)))))
1339    
1340  ;; module-symbol-binding module symbol opt-value  ;; module-symbol-binding module symbol opt-value
1341  ;;  ;;
1342  ;; return the binding of a variable specified by name within  ;; return the binding of a variable specified by name within
1343  ;; a given module, signalling an error if the variable is unbound.  ;; a given module, signalling an error if the variable is unbound.
1344  ;; If the OPT-VALUE is passed, then instead of signalling an error,  ;; If the OPT-VALUE is passed, then instead of signalling an error,
# Line 1358  Line 1360 
1360    
1361    
1362  ;; module-make-local-var! module symbol  ;; module-make-local-var! module symbol
1363  ;;  ;;
1364  ;; ensure a variable for V in the local namespace of M.  ;; ensure a variable for V in the local namespace of M.
1365  ;; If no variable was already there, then create a new and uninitialzied  ;; If no variable was already there, then create a new and uninitialzied
1366  ;; variable.  ;; variable.
# Line 1378  Line 1380 
1380            answer))))            answer))))
1381    
1382  ;; module-add! module symbol var  ;; module-add! module symbol var
1383  ;;  ;;
1384  ;; ensure a particular variable for V in the local namespace of M.  ;; ensure a particular variable for V in the local namespace of M.
1385  ;;  ;;
1386  (define (module-add! m v var)  (define (module-add! m v var)
# Line 1387  Line 1389 
1389    (module-obarray-set! (module-obarray m) v var)    (module-obarray-set! (module-obarray m) v var)
1390    (module-modified m))    (module-modified m))
1391    
1392  ;; module-remove!  ;; module-remove!
1393  ;;  ;;
1394  ;; 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.
1395  ;;  ;;
1396  (define (module-remove! m v)  (define (module-remove! m v)
# Line 1400  Line 1402 
1402    (module-modified m))    (module-modified m))
1403    
1404  ;; MODULE-FOR-EACH -- exported  ;; MODULE-FOR-EACH -- exported
1405  ;;  ;;
1406  ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).  ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
1407  ;;  ;;
1408  (define (module-for-each proc module)  (define (module-for-each proc module)
# Line 1433  Line 1435 
1435  ;;; {Low Level Bootstrapping}  ;;; {Low Level Bootstrapping}
1436  ;;;  ;;;
1437    
1438  ;; make-root-module  ;; make-root-module
1439    
1440  ;; A root module uses the symhash table (the system's privileged  ;; A root module uses the symhash table (the system's privileged
1441  ;; obarray).  Being inside a root module is like using SCM without  ;; obarray).  Being inside a root module is like using SCM without
1442  ;; any module system.  ;; any module system.
1443  ;;  ;;
# Line 1454  Line 1456 
1456    (make-module 1019 '() root-module-closure))    (make-module 1019 '() root-module-closure))
1457    
1458    
1459  ;; make-scm-module  ;; make-scm-module
1460    
1461  ;; An scm module is a module into which the lazy binder copies  ;; An scm module is a module into which the lazy binder copies
1462  ;; variable bindings from the system symhash table.  The mapping is  ;; variable bindings from the system symhash table.  The mapping is
# Line 1545  Line 1547 
1547  ;; 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
1548  ;; 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
1549  ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.  ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
1550  ;;  ;;
1551  (define (module-ref module name . rest)  (define (module-ref module name . rest)
1552    (let ((variable (module-variable module name)))    (let ((variable (module-variable module name)))
1553      (if (and variable (variable-bound? variable))      (if (and variable (variable-bound? variable))
# Line 1559  Line 1561 
1561  ;;  ;;
1562  ;; 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)
1563  ;; to VALUE; if there is no such variable, an error is signaled.  ;; to VALUE; if there is no such variable, an error is signaled.
1564  ;;  ;;
1565  (define (module-set! module name value)  (define (module-set! module name value)
1566    (let ((variable (module-variable module name)))    (let ((variable (module-variable module name)))
1567      (if variable      (if variable
# Line 1570  Line 1572 
1572  ;;  ;;
1573  ;; 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
1574  ;; variable, it is added first.  ;; variable, it is added first.
1575  ;;  ;;
1576  (define (module-define! module name value)  (define (module-define! module name value)
1577    (let ((variable (module-local-variable module name)))    (let ((variable (module-local-variable module name)))
1578      (if variable      (if variable
# Line 1591  Line 1593 
1593  ;; MODULE-USE! module interface  ;; MODULE-USE! module interface
1594  ;;  ;;
1595  ;; Add INTERFACE to the list of interfaces used by MODULE.  ;; Add INTERFACE to the list of interfaces used by MODULE.
1596  ;;  ;;
1597  (define (module-use! module interface)  (define (module-use! module interface)
1598    (set-module-uses! module    (set-module-uses! module
1599                      (cons interface (delq! interface (module-uses module))))                      (cons interface (delq! interface (module-uses module))))
# Line 1609  Line 1611 
1611  ;;; modules.  ;;; modules.
1612  ;;;  ;;;
1613  ;;;             (nested-ref some-root-module '(foo bar baz))  ;;;             (nested-ref some-root-module '(foo bar baz))
1614  ;;;             => <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
1615  ;;;                 the module bound to foo in some-root-module>  ;;;                 the module bound to foo in some-root-module>
1616  ;;;  ;;;
1617  ;;;  ;;;
# Line 1728  Line 1730 
1730                  (try-load-module name))                  (try-load-module name))
1731              ;; Get/create it.              ;; Get/create it.
1732              (make-modules-in (current-module) full-name))))))              (make-modules-in (current-module) full-name))))))
1733                
1734  (define (beautify-user-module! module)  (define (beautify-user-module! module)
1735    (let ((interface (module-public-interface module)))    (let ((interface (module-public-interface module)))
1736      (if (or (not interface)      (if (or (not interface)
# Line 1816  Line 1818 
1818                ((no-backtrace)                ((no-backtrace)
1819                 (set-system-module! module #t)                 (set-system-module! module #t)
1820                 (loop (cdr kws) reversed-interfaces))                 (loop (cdr kws) reversed-interfaces))
1821                (else                    (else
1822                 (error "unrecognized defmodule argument" kws))))))                 (error "unrecognized defmodule argument" kws))))))
1823      module))      module))
1824    
# Line 1885  Line 1887 
1887  ;;     scm_init_ice_9_gtcltk_module  ;;     scm_init_ice_9_gtcltk_module
1888  ;;  ;;
1889  ;;   This is your `module init' function.  It should call  ;;   This is your `module init' function.  It should call
1890  ;;    ;;
1891  ;;     scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);  ;;     scm_register_module_xxx ("ice-9 gtcltk", scm_init_gtcltk);
1892  ;;    ;;
1893  ;;   "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
1894  ;;   replaced by spaces, the rest is untouched. `scm_init_gtcltk' is  ;;   replaced by spaces, the rest is untouched. `scm_init_gtcltk' is
1895  ;;   the real init function that executes the usual initializations  ;;   the real init function that executes the usual initializations
# Line 2015  Line 2017 
2017                                         (string-append libname ".la"))))                                         (string-append libname ".la"))))
2018      (and (file-exists? libtool-filename)      (and (file-exists? libtool-filename)
2019           libtool-filename)))           libtool-filename)))
2020                                  
2021  (define (try-using-sharlib-name libdir libname)  (define (try-using-sharlib-name libdir libname)
2022    (in-vicinity libdir (string-append libname ".so")))    (in-vicinity libdir (string-append libname ".so")))
2023    
# Line 2143  Line 2145 
2145  ((let* ((names '((eval-options-interface  ((let* ((names '((eval-options-interface
2146                    (eval-options eval-enable eval-disable)                    (eval-options eval-enable eval-disable)
2147                    (eval-set!))                    (eval-set!))
2148                    
2149                   (debug-options-interface                   (debug-options-interface
2150                    (debug-options debug-enable debug-disable)                    (debug-options debug-enable debug-disable)
2151                    (debug-set!))                    (debug-set!))
2152                  
2153                   (evaluator-traps-interface                   (evaluator-traps-interface
2154                    (traps trap-enable trap-disable)                    (traps trap-enable trap-disable)
2155                    (trap-set!))                    (trap-set!))
2156                    
2157                   (read-options-interface                   (read-options-interface
2158                    (read-options read-enable read-disable)                    (read-options read-enable read-disable)
2159                    (read-set!))                    (read-set!))
2160                    
2161                   (print-options-interface                   (print-options-interface
2162                    (print-options print-enable print-disable)                    (print-options print-enable print-disable)
2163                    (print-set!))                    (print-set!))
# Line 2290  Line 2292 
2292    (let ((status #f)    (let ((status #f)
2293          (interactive #t))          (interactive #t))
2294      (define (loop first)      (define (loop first)
2295        (let ((next        (let ((next
2296               (catch #t               (catch #t
2297    
2298                      (lambda ()                      (lambda ()
# Line 2302  Line 2304 
2304                                         (with-traps                                         (with-traps
2305                                          (lambda ()                                          (lambda ()
2306                                            (first)                                            (first)
2307                                          
2308                                            ;; This line is needed because mark                                            ;; This line is needed because mark
2309                                            ;; doesn't do closures quite right.                                            ;; doesn't do closures quite right.
2310                                            ;; Unreferenced locals should be                                            ;; Unreferenced locals should be
# Line 2315  Line 2317 
2317                                       (lambda () (mask-signals))))                                       (lambda () (mask-signals))))
2318    
2319                                    lazy-handler-dispatch))                                    lazy-handler-dispatch))
2320                        
2321                      (lambda (key . args)                      (lambda (key . args)
2322                        (case key                        (case key
2323                          ((quit)                          ((quit)
# Line 2362  Line 2364 
2364                                    (apply bad-throw key args))))))))))                                    (apply bad-throw key args))))))))))
2365          (if next (loop next) status)))          (if next (loop next) status)))
2366      (set! set-batch-mode?! (lambda (arg)      (set! set-batch-mode?! (lambda (arg)
2367                               (cond (arg                               (cond (arg
2368                                      (set! interactive #f)                                      (set! interactive #f)
2369                                      (restore-signals))                                      (restore-signals))
2370                                     (#t                                     (#t
# Line 2560  Line 2562 
2562                                         -eval                                         -eval
2563                                         -print)))                                         -print)))
2564        (-quit status))))        (-quit status))))
2565      
2566    
2567    
2568  ;;; {IOTA functions: generating lists of numbers}  ;;; {IOTA functions: generating lists of numbers}
# Line 2696  Line 2698 
2698                (module-define! (current-module)                (module-define! (current-module)
2699                                ',name                                ',name
2700                                (module-ref (current-module) ',name #f))                                (module-ref (current-module) ',name #f))
2701                                  
2702                ;; Make sure that local is exported:                ;; Make sure that local is exported:
2703                ;;                ;;
2704                (module-add! public-i ',name                (module-add! public-i ',name
2705                             (module-variable (current-module) ',name)))                             (module-variable (current-module) ',name)))
2706                                  
2707              ;; Now (re)define the var normally.  Bernard URBAN              ;; Now (re)define the var normally.  Bernard URBAN
2708              ;; suggests we use eval here to accomodate Hobbit; it lets              ;; suggests we use eval here to accomodate Hobbit; it lets
2709              ;; the interpreter handle the define-private form, which              ;; the interpreter handle the define-private form, which
# Line 2728  Line 2730 
2730                                 (module-define! (current-module)                                 (module-define! (current-module)
2731                                                 ',name                                                 ',name
2732                                                 (module-ref (current-module) ',name #f))                                                 (module-ref (current-module) ',name #f))
2733                                  
2734                                 ;; Make sure that local is exported:                                 ;; Make sure that local is exported:
2735                                 ;;                                 ;;
2736                                 (module-add! public-i ',name (module-variable (current-module) ',name)))                                 (module-add! public-i ',name (module-variable (current-module) ',name)))
2737                                  
2738                               ;; Now (re)define the var normally.                               ;; Now (re)define the var normally.
2739                               ;;                               ;;
2740                               (defmacro ,@ args))))))                               (defmacro ,@ args))))))
# Line 2772  Line 2774 
2774        (lambda () (fluid-ref using-readline?))        (lambda () (fluid-ref using-readline?))
2775        (lambda (v) (fluid-set! using-readline? v)))))        (lambda (v) (fluid-set! using-readline? v)))))
2776    
2777  ;; this is just (scm-style-repl) with a wrapper to install and remove  ;; this is just (scm-style-repl) with a wrapper to install and remove
2778  ;; signal handlers.  ;; signal handlers.
2779  (define (top-repl)  (define (top-repl)
2780    
2781    ;; Load emacs interface support if emacs option is given.    ;; Load emacs interface support if emacs option is given.
2782    (if (and (module-defined? the-root-module 'use-emacs-interface)    (if (and (module-defined? the-root-module 'use-emacs-interface)

Legend:
Removed from v.1.205  
changed lines
  Added in v.1.205.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26