Update of /cvsroot/foo/foo/elkfoo/scm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26097
Added Files:
Makefile.am toplevel.foo.in
Log Message:
initial checkin
--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/Makefile.am
# 2004 rumori
# $Id: Makefile.am,v 1.1 2004/08/07 21:25:05 rumori Exp $
NULL =
SUBDIRS = kernel # control
pkgdata_DATA = $(FOO_FILES)
FOO_FILES = \
toplevel.foo \
$(NULL)
# generate toplevel.foo
replace = sed \
-e 's,@datadir\@,$(pkgdatadir),g' \
-e 's,@ELKFOO_LIB_DIR\@,$(ELKFOO_LIB_DIR),g'
toplevel.foo: toplevel.foo.in
rm -f toplevel.foo.tmp toplevel.foo
$(replace) \
-e 's,@edited_input\@,toplevel.foo: generated from toplevel.foo.in by Makefile.am,' \
$(srcdir)/toplevel.foo.in > toplevel.foo.tmp
mv toplevel.foo.tmp toplevel.foo
EXTRA_DIST = toplevel.foo.in
CLEANFILES = \
toplevel.foo \
toplevel.foo.tmp \
$(NULL)
--- NEW FILE: toplevel.foo.in ---
;;; -*-Scheme-*-
;;;
;; @edited_input@
;; set load path according to installation
(begin
(define foo-scm-path "@datadir@")
(define foo-lib-path "@ELKFOO_LIB_DIR@")
(define (add-to-load-path path)
;; don't add if not expanded by autoconf
(if (> (string-length path) 1)
;; if ./ at the beginning of load-path, keep it there
(if (string=? (car load-path) ".")
(set! load-path
(cons (car load-path)
(cons path
(cdr load-path))))
(set! load-path
(cons path load-path)))))
(add-to-load-path foo-lib-path)
(add-to-load-path foo-scm-path))
;;; requirements
(require 'unix)
(require 'oops)
(require 'struct)
(require 'elkfoo) ;; load the foo library
(autoload 'pp 'pp.scm)
(autoload 'apropos 'apropos.scm)
(autoload 'sort 'qsort.scm)
(autoload 'define-structure 'struct.scm)
(autoload 'describe 'describe.scm)
(autoload 'backtrace 'debug.scm)
(autoload 'inspect 'debug.scm)
;; readline support (depending on environment var)
(if (string? (getenv "ELK_READLINE"))
(if (> (string-length (getenv "ELK_READLINE")) 1)
(require 'readline.la)))
(if (feature? 'readline.la)
(define foo-prompt-base "foo> "))
;; foo scripting
(define foo-script-file "")
(define load-foo-script-file #f)
;;; Read-eval-print loop and error handler (readline extension support)
(define ?)
(define ??)
(define ???)
(define !)
(define !!)
(define !!!)
(define &)
(define (rep-loop env)
(define input)
(define value)
(let loop ()
(set! ??? ??)
(set! ?? ?)
(set! ? &)
;;; X Windows hack
(if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy))
(display-flush-output dpy))
(if (feature? 'readline.la)
(if (> rep-level 0)
(readline-set-prompt (string-append
(format #f "~a-" rep-level)
foo-prompt-base))
(readline-set-prompt foo-prompt-base))
(begin
(if (> rep-level 0)
(format #t "~a-" rep-level))
(display "foo> ")))
(if load-foo-script-file
(begin
(set! load-foo-script-file #f)
(load foo-script-file))
(begin
(if (feature? 'readline.la)
(set! input (readline-read))
(set! input (read)))
(set! & input)
(if (not (eof-object? input))
(begin
(set! value (eval input env))
(set! !!! !!)
(set! !! !)
(set! ! value)
(write value)
(newline)
(loop)))))))
(define rep-frames)
(define rep-level)
(set! interrupt-handler
(lambda ()
(format #t "~%\7Interrupt!~%")
(let ((next-frame (car rep-frames)))
(next-frame #t))))
(define-macro (push-frame control-point)
`(begin
(set! rep-frames (cons ,control-point rep-frames))
(set! rep-level (1+ rep-level))))
(define-macro (pop-frame)
'(begin
(set! rep-frames (cdr rep-frames))
(set! rep-level (1- rep-level))))
(define (error-print error-msg)
(format #t "~s: " (car error-msg))
(apply format `(#t ,@(cdr error-msg)))
(newline))
(set! error-handler
(lambda error-msg
(error-print error-msg)
(let loop ((intr-level (enable-interrupts)))
(if (positive? intr-level)
(loop (enable-interrupts))))
(let loop ()
(if (call-with-current-continuation
(lambda (control-point)
(push-frame control-point)
(rep-loop (the-environment))
#f))
(begin
(pop-frame)
(loop))))
(newline)
(pop-frame)
(let ((next-frame (car rep-frames)))
(next-frame #t))))
(define top-level-environment (the-environment))
(define (top-level)
(let loop ()
;;; Allow GC to free old rep-frames when we get here on "reset":
(set! rep-frames (list top-level-control-point))
(if (call-with-current-continuation
(lambda (control-point)
(set! rep-frames (list control-point))
(set! top-level-control-point control-point)
(set! rep-level 0)
(rep-loop top-level-environment)
#f))
(loop))))
(define (the-top-level)
(top-level)
(newline)
(if (feature? 'foo)
(if (> (string-length foo-script-file) 0)
(begin
(if (bound? 'foo:cleanup)
(foo:cleanup))
(exit))
(begin
(format #t "do you really want to exit foo? [ny] (n): ")
(if (equal? (read-char) #\y)
(begin
(format #t "bye~%")
(if (bound? 'foo:cleanup)
(foo:cleanup))
(exit))
(the-top-level))))
(exit)))
;; load init
; (if (feature? 'context)
; (begin
; (load "initialize.foo")
; ;; system wide defaults
; (if (file-exists? "/etc/foo/init.foo")
; (load "/etc/foo/init.foo"))
; ;; user defaults (backwards compat)
; (if (file-exists? (tilde-expand "~/.initfoo"))
; (load "~/.initfoo"))
; ;; wd defaults (backwards compat)
; (if (and (not (string=? (getenv "HOME") (getwd)))
; (file-exists? ".initfoo"))
; (load ".initfoo"))
; ;; user defaults
; (if (file-exists? (tilde-expand "~/.foo/init.foo"))
; (load "~/.foo/init.foo"))
; ;; wd defaults
; (if (file-exists? ".init.foo")
; (load ".init.foo"))))
(if (not (null? (command-line-args)))
(if (file-exists? (car (command-line-args)))
(begin
(set! foo-script-file (car (command-line-args)))
(set! load-foo-script-file #t))
(begin
(format #t "couldn't load foo script ~s\n" (car (command-line-args)))
(if (bound? 'foo:cleanup)
(foo:cleanup))
(exit))))
(the-top-level)
|
