643 lines
20 KiB
Plaintext
643 lines
20 KiB
Plaintext
;;;;
|
|
;;;; i n i t . s t k -- The file launched at startup
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
;;;; Creation date: ??-Sep-1993 ??:??
|
|
;;;; Last file update: 14-Sep-1999 21:50 (eg)
|
|
;;;;
|
|
|
|
;;;==============================================================================
|
|
;;;
|
|
;;; Define some global variables (i.e. in the STk module)
|
|
;;;
|
|
;;;==============================================================================
|
|
|
|
(with-module STk
|
|
(import Scheme)
|
|
(define *print-banner* #t) ; #f to avoid the Copyright message
|
|
(define *debug* #f) ; #t for debuggging (disable macro inlining)
|
|
(define *argc* (length *argv*))
|
|
(define Tk:initialized? #f)
|
|
(define *shared-suffix* (cond
|
|
((string=? (machine-type) "Ms-Win32") "dll")
|
|
((string=? (substring (machine-type) 0 2) "HP") "sl")
|
|
(else "so")))
|
|
(define *load-suffixes* (list "stk" "stklos" "scm" *shared-suffix*))
|
|
(define *load-path* #f)
|
|
(define *load-verbose* #f))
|
|
|
|
;;;==============================================================================
|
|
;;;
|
|
;;; The following code is in the Scheme module (since this file is loaded in the
|
|
;;; Scheme module)
|
|
;;;
|
|
;;;==============================================================================
|
|
|
|
(define call-with-current-continuation ;; The R5RS one
|
|
(let ((call/cc call-with-current-continuation)) ;; The R4RS one
|
|
(lambda (proc)
|
|
(call/cc (lambda (cont)
|
|
(proc (lambda l (cont (apply values l)))))))))
|
|
|
|
(define call/cc call-with-current-continuation) ;; To make life easier
|
|
|
|
(define ! system)
|
|
|
|
(define (os-kind)
|
|
(if (string=? (machine-type) "Ms-Win32")
|
|
'Windows
|
|
'Unix))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Some stuff for defining macros
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define define-macro #f)
|
|
(define %replace #f)
|
|
(define %beginify #f)
|
|
|
|
(let ((if if) (and and) (begin begin) (set-car! set-car!) (set-cdr! set-cdr!)
|
|
(not not) (pair? pair?) (car car) (cdr cdr)
|
|
(null? null?) (cons cons)
|
|
(let let) (macro macro) (list list) (append append))
|
|
|
|
(set! %replace
|
|
(lambda (before after)
|
|
(if (and (not *debug*) (pair? before) (pair? after))
|
|
(begin
|
|
(set-car! before (car after))
|
|
(set-cdr! before (cdr after))))
|
|
after))
|
|
|
|
(set! %beginify
|
|
(lambda (forms)
|
|
(if (null? (cdr forms)) (car forms) (cons 'begin forms))))
|
|
|
|
(set! define-macro
|
|
(macro form
|
|
(let ((name (car (car (cdr form))))
|
|
(args (cdr (car (cdr form)))))
|
|
(list 'define name
|
|
(list 'macro 'params
|
|
(list '%replace
|
|
'params
|
|
(list 'apply
|
|
(append (list 'lambda args)
|
|
(cdr (cdr form)))
|
|
(list 'cdr 'params)))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Some utilities
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define gensym
|
|
(let ((counter 0))
|
|
(lambda prefix
|
|
(set! counter (+ counter 1))
|
|
(string->uninterned-symbol
|
|
(string-append (if (null? prefix) "G" (car prefix))
|
|
(number->string counter))))))
|
|
|
|
(define (apropos s)
|
|
(if (not (symbol? s)) (error "apropos: bad symbol" s))
|
|
(let ((res '())
|
|
(env (the-environment))
|
|
(str (symbol->string s)))
|
|
|
|
(do ((l (cdr (environment->list env)) (cdr l))); cdr to avoid the binding to "s"
|
|
((null? l) (if (null? res) #f (list->set res)))
|
|
(do ((v (car l) (cdr v)))
|
|
((null? v))
|
|
(if (and (string-find? str (symbol->string (caar v)))
|
|
(symbol-bound? (caar v)))
|
|
(set! res (cons (caar v) res)))))))
|
|
|
|
(define (documentation x)
|
|
"provides documentation for its parameter if it exists"
|
|
(define (nodoc)
|
|
(format #t "No documentation available for ~A\n" x))
|
|
(cond
|
|
((closure? x) (let ((body (procedure-body x)))
|
|
(if (string? (caddr body))
|
|
(format #t "~A\n" (caddr body))
|
|
(nodoc))))))
|
|
|
|
(define make-unbound
|
|
(let ((unbound (make-vector 1)))
|
|
(lambda ()
|
|
(vector-ref unbound 0))))
|
|
|
|
(define unbound?
|
|
(let ((unbound (make-unbound)))
|
|
(lambda (o)
|
|
(eq? o unbound))))
|
|
|
|
(define (make-undefined)
|
|
(if #f #t))
|
|
|
|
(define (undefined? o)
|
|
(eq? o (if #f #t)))
|
|
|
|
(define-macro (define-variable var value) ;; The Elisp/CL defvar
|
|
`(with-module STk
|
|
(unless (symbol-bound? ',var) (define ,var ,value))))
|
|
|
|
(define-macro (receive vars producer . body)
|
|
`(call-with-values (lambda () ,producer)
|
|
(lambda ,vars ,@body)))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Random
|
|
;;;; This version of random is constructed over the C one. It can return
|
|
;;;; bignum numbers. Idea is due to Nobuyuki Hikichi <hikichi@sra.co.jp>
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define random
|
|
(let ((C-random random)
|
|
(max-rand #x7fffffff)) ; Probably more on 64 bits machines
|
|
(letrec ((rand (lambda (n)
|
|
(cond
|
|
((zero? n) 0)
|
|
((< n max-rand) (C-random n))
|
|
(else (+ (* (rand (quotient n max-rand)) max-rand)
|
|
(rand (remainder n max-rand))))))))
|
|
(lambda (n)
|
|
(if (zero? n)
|
|
(error "random: bad number: 0")
|
|
(rand n))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; do
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-macro (do inits test . body)
|
|
(let ((loop-name (gensym)))
|
|
`(letrec ((,loop-name
|
|
(lambda ,(map car inits)
|
|
(if ,(car test)
|
|
(begin ,@(if (null? (cdr test))
|
|
(list (make-undefined))
|
|
(cdr test)))
|
|
(begin ,@body
|
|
(,loop-name ,@(map (lambda (init)
|
|
(if (null? (cddr init))
|
|
(car init)
|
|
(caddr init)))
|
|
inits)))))))
|
|
(,loop-name ,@(map cadr inits)))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; dotimes
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-macro (dotimes binding . body)
|
|
(if (list? binding)
|
|
;; binding is a list
|
|
(let ((var #f) (count #f) (result #f))
|
|
(case (length binding)
|
|
(2 (set! var (car binding))
|
|
(set! count (cadr binding))
|
|
(set! result (make-undefined)))
|
|
(3 (set! var (car binding))
|
|
(set! count (cadr binding))
|
|
(set! result (caddr binding)))
|
|
(else (error "dotimes: bad binding construct: ~S" binding)))
|
|
`(do ((,var 0 (+ ,var 1)))
|
|
((>= ,var ,count) ,result)
|
|
,@body))
|
|
;; binding is ill-formed
|
|
(error "dotimes: binding is not a list: ~S" binding)))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; case
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-macro (case key . clauses)
|
|
;; conditionally execute the clause eqv? to key
|
|
(define (case-make-clauses key)
|
|
`(cond ,@(map
|
|
(lambda (clause)
|
|
(if (pair? clause)
|
|
(let ((case (car clause))
|
|
(exprs (cdr clause)))
|
|
(cond ((eq? case 'else)
|
|
`(else ,@exprs))
|
|
((pair? case)
|
|
(if (= (length case) 1)
|
|
`((eqv? ,key ',(car case)) ,@exprs)
|
|
`((memv ,key ',case) ,@exprs)))
|
|
(else
|
|
`((eqv? ,key ',case) ,@exprs))))
|
|
(error "case: invalid syntax in ~a" clause)))
|
|
clauses)))
|
|
(if (pair? key)
|
|
(let ((newkey (gensym)))
|
|
`(let ((,newkey ,key))
|
|
,(case-make-clauses newkey)))
|
|
(case-make-clauses key)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; fluid-let
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-macro (fluid-let bindings . body)
|
|
(let* ((vars (map car bindings))
|
|
(vals (map cadr bindings))
|
|
(tmps (map (lambda (x) (gensym)) vars)))
|
|
`(let ,(map list tmps vars)
|
|
(dynamic-wind
|
|
(lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars vals))
|
|
(lambda () ,@body)
|
|
(lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars tmps))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Some usal macros
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-macro (unquote form)
|
|
(error "Usage of unquote outside of quasiquote in ,~A" form))
|
|
|
|
(define-macro (unquote-splicing form)
|
|
(error "Usage of unquote-splicing outside of quasiquote in ,@~A" form))
|
|
|
|
(define 1+ (macro form (list + (cadr form) 1)))
|
|
(define 1- (macro form (list - (cadr form) 1)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Section 6.10
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (call-with-input-file string proc)
|
|
(let* ((file (open-input-file string))
|
|
(result (proc file)))
|
|
(close-input-port file)
|
|
result))
|
|
|
|
(define (call-with-output-file string proc)
|
|
(let* ((file (open-output-file string))
|
|
(result (proc file)))
|
|
(close-output-port file)
|
|
result))
|
|
|
|
|
|
(define (call-with-input-string string proc)
|
|
(proc (open-input-string string)))
|
|
|
|
(define (call-with-output-string proc)
|
|
(let ((str (open-output-string)))
|
|
(proc str)
|
|
(get-output-string str)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; File management
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (build-path-from-shell-variable var)
|
|
(let ((path (getenv var)))
|
|
(if path
|
|
(split-string path (if (eqv? (os-kind) 'Unix) ":" ";"))
|
|
'())))
|
|
|
|
(let ((lib (%library-location)))
|
|
;; If user has specified a load path with STK_LOAD_PATH, use it
|
|
;; Always append STK_LIBRARY at end to be sure to find our files
|
|
(set! *load-path* (append (list ".")
|
|
(build-path-from-shell-variable "STK_LOAD_PATH")
|
|
(list (expand-file-name
|
|
(string-append lib "/../site-scheme"))
|
|
(string-append lib "/STk")
|
|
(string-append lib "/" (machine-type))))))
|
|
|
|
;;;
|
|
;;; Require/Provide/Provided?
|
|
;;;
|
|
|
|
(define require #f) ; This is a little bit tricky here: variables are
|
|
(define provide #f) ; defined in the Scheme module, but their associated
|
|
(define provided? #f) ; closure is in the STk module. In this way, the
|
|
; LOAD done in the REQUIRE procedure is done in the
|
|
; global namespace, which is what is desired for REQUIRE.
|
|
|
|
(with-module STk
|
|
(let ((provided '()))
|
|
|
|
(set! require (lambda (what)
|
|
(unless (member what provided)
|
|
(load what (current-module))
|
|
(unless (member what provided)
|
|
(format #t "WARNING: ~S was not provided~%" what)))
|
|
what))
|
|
|
|
(set! provide (lambda (what)
|
|
(unless (member what provided)
|
|
(set! provided (cons what provided)))
|
|
what))
|
|
|
|
(set! provided? (lambda (what)
|
|
(and (member what provided) #t)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Port conversions
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (port->string p)
|
|
(unless (or (input-port? p) (input-string-port? p))
|
|
(error "port->string: Bad port ~S" p))
|
|
(let loop ((res '()))
|
|
(let ((line (read-line p)))
|
|
(if (eof-object? line)
|
|
(apply string-append (reverse res))
|
|
(loop (cons "\n" (cons line res)))))))
|
|
|
|
(define (port->list reader p)
|
|
(unless (or (input-port? p) (input-string-port? p))
|
|
(error "port->list: Bad port ~S" p))
|
|
;; Read all the lines of port and put them in a list
|
|
(let loop ((res '()) (sexp (reader p)))
|
|
(if (eof-object? sexp)
|
|
(reverse res)
|
|
(loop (cons sexp res) (reader p)))))
|
|
|
|
(define (port->sexp-list p)
|
|
(port->list read p))
|
|
|
|
(define (port->string-list p)
|
|
(port->list read-line p))
|
|
|
|
(define (exec command)
|
|
(call-with-input-file (string-append "| " command) port->string))
|
|
|
|
(define (exec-string-list command)
|
|
(call-with-input-file (string-append "| " command) port->string-list))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Misc
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (closure? obj)
|
|
(and (procedure? obj) (procedure-body obj) #t))
|
|
|
|
(define (primitive? obj)
|
|
(and (procedure? obj) (not (procedure-body obj)) #t))
|
|
|
|
(define (widget? obj)
|
|
(and (tk-command? obj) (not (catch (obj 'configure)))))
|
|
|
|
|
|
(define (& . l)
|
|
(let loop ((l l) (res ""))
|
|
(if (null? l)
|
|
res
|
|
(let ((e (car l)))
|
|
(loop (cdr l)
|
|
(string-append res
|
|
(cond
|
|
((string? e) e)
|
|
((symbol? e) (symbol->string e))
|
|
((widget? e) (widget->string e))
|
|
((number? e) (number->string e))
|
|
(ELSE (format #f "~S" e)))))))))
|
|
|
|
(define-macro (unwind-protect body . unwind-forms)
|
|
`(dynamic-wind
|
|
(lambda () #f)
|
|
(lambda () ,body)
|
|
(lambda () ,@unwind-forms)))
|
|
|
|
(define-macro (when test . body)
|
|
`(if ,test ,@(if (= (length body) 1) body `((begin ,@body)))))
|
|
|
|
(define-macro (unless test . body)
|
|
`(if (not ,test) ,@(if (= (length body) 1) body `((begin ,@body)))))
|
|
|
|
(define-macro (multiple-value-bind vars form . body)
|
|
`(apply (lambda ,vars ,@body) ,form))
|
|
|
|
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
|
|
(cond ; must be "isomorph"
|
|
((null? (car l)) '())
|
|
((pair? (car l)) (cons (apply fn (map car l))
|
|
(apply map* fn (map cdr l))))
|
|
(else (apply fn l))))
|
|
|
|
(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
|
|
(cond ; must be "isomorph"
|
|
((null? (car l)) '())
|
|
((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
|
|
(else (apply fn l))))
|
|
|
|
(define (some pred l)
|
|
(if (null? l)
|
|
#f
|
|
(or (pred (car l))
|
|
(some pred (cdr l)))))
|
|
|
|
(define (every pred l)
|
|
(if (null? l)
|
|
#t
|
|
(and (pred (car l) )
|
|
(every pred (cdr l)))))
|
|
|
|
|
|
;; Tell if the parameter string is a complete (or a set of complete) sexpr
|
|
(define (complete-sexpr? s)
|
|
(with-input-from-string s
|
|
(lambda ()
|
|
(let Loop ()
|
|
(let ((sexpr #f))
|
|
(if (catch (set! sexpr (read)))
|
|
#f
|
|
(or (eof-object? sexpr) (Loop))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Set functions
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list->set l)
|
|
(letrec ((rem-dupl (lambda (l res)
|
|
(cond
|
|
((null? l) res)
|
|
((memv (car l) res) (rem-dupl (cdr l) res))
|
|
(ELSE (rem-dupl (cdr l) (cons (car l)
|
|
res)))))))
|
|
(rem-dupl l '())))
|
|
|
|
(define (set-union l1 l2)
|
|
(list->set (append l1 l2)))
|
|
|
|
(define (set-intersection l1 l2)
|
|
(cond ((null? l1) l1)
|
|
((null? l2) l2)
|
|
((memv (car l1) l2) (cons (car l1) (set-intersection (cdr l1) l2)))
|
|
(else (set-intersection (cdr l1) l2))))
|
|
|
|
(define (set-difference l1 l2)
|
|
(cond ((null? l1) l1)
|
|
((memv (car l1) l2) (set-difference (cdr l1) l2))
|
|
(else (cons (car l1) (set-difference (cdr l1) l2)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Module stuff
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define-macro (export . l)
|
|
`(begin
|
|
,@(map (lambda (x)
|
|
(let ((x (if (and (pair? x) (eq? (car x) 'setter))
|
|
(extended-name->scheme-name x)
|
|
x)))
|
|
`(export-symbol ',x (current-module))))
|
|
l)
|
|
,(make-undefined)))
|
|
|
|
|
|
(define ~ with-module)
|
|
|
|
#| FIXME: Probably more harmful than useful. Delete it?
|
|
|
|
(define-macro (duplicate-module-exports from to . prefix)
|
|
(let* ((prefix (if (null? prefix) "" (symbol->string (car prefix))))
|
|
(exports (module-exports (find-module from)))
|
|
(symbols (map (lambda (x)
|
|
(string->symbol (string-append prefix (symbol->string x))))
|
|
exports)))
|
|
`(with-module ,to
|
|
,@(map (lambda (x y)
|
|
`(define ,x (with-module ,from ,y)))
|
|
symbols exports))))
|
|
|#
|
|
|
|
;;;
|
|
;;; quit and bye procedures. Since Tk redefine exit, they cannot be simple aliases
|
|
;;;
|
|
(define quit (lambda l (apply exit l)))
|
|
(define bye (lambda l (apply exit l)))
|
|
|
|
;;;==============================================================================
|
|
;;;
|
|
;;; Code for STklos autoloading
|
|
;;;
|
|
;;;==============================================================================
|
|
|
|
(define-module STklos
|
|
(import Scheme)
|
|
(export define-class define-method define-generic describe make method)
|
|
|
|
(autoload "stklos" define-class define-method define-generic make method)
|
|
(autoload "describe" describe))
|
|
|
|
|
|
;;;==============================================================================
|
|
;;;
|
|
;;; Finish initializations
|
|
;;;
|
|
;;;==============================================================================
|
|
|
|
(with-module Scheme
|
|
(autoload "defsyntax" define-syntax)
|
|
;; SRFIs
|
|
(autoload "srfi-0" cond-expand)
|
|
(autoload "srfi-2" land*)
|
|
(autoload "srfi-7" program))
|
|
|
|
|
|
|
|
|
|
(with-module STk
|
|
;; Make the STklos autoload symbols accessible from the global scope
|
|
(import STklos)
|
|
|
|
;; Define some useful autoload
|
|
(autoload "fs" basename dirname decompose-file-name)
|
|
(autoload "process" run-process process?)
|
|
(autoload "regexp" string->regexp regexp? regexp-replace regexp-replace-all)
|
|
(autoload "trace" trace untrace)
|
|
(autoload "hash" make-hash-table hash-table-hash)
|
|
(autoload "socket" make-server-socket make-client-socket)
|
|
(autoload "match" match-case match-lambda)
|
|
(autoload "ffi" define-external external-exists?)
|
|
(autoload "extset" setter extended-name->scheme-name)
|
|
(autoload "pp" pp) ;; martine pretty-print package
|
|
|
|
|
|
|
|
;; Procedure used for writing the components of toplevel result. This
|
|
;; is far from perfect, but this is sufficient for the most obvious
|
|
;; cases (shared sublists, which are not circular structures, typically
|
|
;; for n-queens problems ...)
|
|
(define repl-write (lambda (x) ((if (list? x) write write*) x)))
|
|
|
|
;; Procedure called for prompting the user
|
|
(define (repl-display-prompt module)
|
|
(let ((RDP (lambda (module)
|
|
(let ((p (current-error-port))
|
|
(n (module-name module)))
|
|
(flush) ; flush *stdout* before printing the prompt
|
|
(format p "~A> " (case n
|
|
((stk) "STk")
|
|
((stklos) "STklos")
|
|
((scheme) "Scheme")
|
|
((tk) "Tk")
|
|
(else n)))
|
|
(flush p)))))
|
|
;; RDP is the real prompt procedure. The body of this function is
|
|
;; only executed for the displaying the first prompt
|
|
(when Tk:initialized?
|
|
;; This autoload was in tk-init but it causes problems when an
|
|
;; error occur in the file loaded before the first prompt
|
|
;; appears. Now, we use the graphical report error only when
|
|
;; everything is correctly initialized.
|
|
(tk-set-error-handler!)) ; make STk:report-error and bgerror autoload
|
|
|
|
(set! repl-display-prompt RDP)
|
|
(repl-display-prompt module)))
|
|
|
|
;; Procedure called for printing toplevel results
|
|
(define (repl-display-result result)
|
|
(if (eqv? result (make-undefined))
|
|
(when *last-defined*
|
|
(format #t "~S\n" *last-defined*)
|
|
(set! *last-defined* #f))
|
|
(call-with-values (lambda () result)
|
|
(lambda l
|
|
(for-each (lambda (x) (repl-write x) (newline)) l))))))
|