~ chicken-core (chicken-5) 1402eea7aec2611dfe48542715b1492561072f41

commit 1402eea7aec2611dfe48542715b1492561072f41
Author:     unknown <felix@.(none)>
AuthorDate: Mon Oct 19 12:12:46 2009 +0200
Commit:     unknown <felix@.(none)>
CommitDate: Mon Oct 19 12:12:46 2009 +0200

    henrietta shows version in comment marker; removed unused ##sys#syntactic-environment?

diff --git a/csc.scm b/csc.scm
index 472002b0..b625af8e 100644
--- a/csc.scm
+++ b/csc.scm
@@ -161,7 +161,7 @@
     (-b "-block") ) )
 
 (define short-options
-  (string->list "PHhsfiENxubvwAOeWkctgS") )
+  (string->list "PHhsfiENxubvwAOeWkctgSJ") )
 
 
 ;;; Variables:
diff --git a/expand.scm b/expand.scm
index 853cf61f..1e8b0b51 100644
--- a/expand.scm
+++ b/expand.scm
@@ -135,69 +135,6 @@
 (define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
 (define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
 
-; Workalike of '##sys#environment?' for syntactic environments
-(define (##sys#syntactic-environment? obj)
-
-  (define (simple-environment? obj)
-    (and (list? obj)
-         (or (null? obj)
-             (simple-environment-entry? (car obj))
-             #; ;enough already
-             (call-with-current-continuation
-               (lambda (return)
-                 (##sys#for-each
-                  (lambda (x) (unless (simple-environment-entry? x) (return #f) ) )
-                  obj)
-               #t ) ) ) ) )
-
-  (define (simple-environment-entry? obj)
-    (and (pair? obj)
-         (symbol? (car obj))
-         (symbol? (cdr obj)) ) )
-
-  (define (macro-environment? obj)
-    (and (list? obj)
-         (or (null? obj)
-             (macro-environment-entry? (car obj))
-             #; ;enough already
-             (call-with-current-continuation
-               (lambda (return)
-                 (##sys#for-each
-                  (lambda (x) (unless (macro-environment-entry? x) (return #f) ) )
-                  obj)
-               #t ) ) ) ) )
-
-  (define (macro-environment-entry? obj)
-    (and (pair? obj) (= 3 (length obj))
-         (symbol? (car obj))
-         (list? (cadr obj))
-         #;(##sys#syntactic-environment? (cadr x)) ;enough already
-         (procedure? (caddr obj)) ) )
-
-  (or (simple-environment? obj)
-      (macro-environment? obj) ) )
-
-; Workalike of '##sys#environment-symbols' for syntactic environments
-; (I think :-)
-(define (##sys#syntactic-environment-symbols env pred)
-  (define (try-alias id)
-    (or (##sys#get id '##core#real-name)
-        (let ((alias (##sys#get id '##core#macro-alias)))
-          (cond ((not alias) id)
-                ((pair? alias) id)
-                (else alias) ) ) ) )
-  (let ((syms '()))
-    (##sys#for-each
-     (lambda (cell)
-       (let ((id (car cell)))
-         (cond ((pred id)
-                (set! syms (cons id syms)) )
-               ((try-alias id) =>
-                (lambda (name)
-                  (when (pred name) (set! syms (cons name syms))) ) ) ) ) )
-     env)
-   syms ) )
-
 (define (##sys#extend-macro-environment name se handler)
   (let ((me (##sys#macro-environment)))
     (cond ((lookup name me) =>
diff --git a/library.scm b/library.scm
index 4a65a7c0..bd572208 100644
--- a/library.scm
+++ b/library.scm
@@ -167,7 +167,7 @@ EOF
      ##sys#unicode-surrogate? ##sys#surrogates->codepoint ##sys#write-char/port
      ##sys#update-errno ##sys#file-info close-output-port close-input-port ##sys#peek-unsigned-integer
      continuation-graft char-downcase string-copy remainder floor ##sys#exact? list->string
-     ##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#list ##sys#apply ##sys#make-vector
+     ##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#apply ##sys#make-vector
      ##sys#write-char ##sys#force-finalizers ##sys#cleanup-before-exit ##sys#write-char-0
      ##sys#default-read-info-hook ##sys#read-error) ) ] )
 
diff --git a/scripts/henrietta.scm b/scripts/henrietta.scm
index b3a6fe81..5fdbfc52 100644
--- a/scripts/henrietta.scm
+++ b/scripts/henrietta.scm
@@ -89,10 +89,10 @@
 	       (let ((ff (string-append dir "/" f))
 		     (pf (string-append prefix "/" f)))
 		 (cond ((directory? ff)
-			(print "\n#|--------------------|# \"" pf "/\" 0")
+			(print "\n#|-------------------- " version " |# \"" pf "/\" 0")
 			(walk ff pf))
 		       (else
-			(print "\n#|--------------------|# \"" pf "\" " (file-size ff))
+			(print "\n#|-------------------- " version " |# \"" pf "\" " (file-size ff))
 			(display (read-all ff)))))))
 	   files)))
       (print "\n#!eof") ) )