[foo-cvs] foo/elkfoo/scm Makefile.am,NONE,1.1 toplevel.foo.in,NONE,1.1

[Martin R. <ru...@us...>]

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)