From 645587e343ef1f3961fa6f2f0ba08af0bdeddb64 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 18 May 2009 02:36:24 -0700
Subject: [PATCH] Provide abstractions for writing copyright and license
statements. These are useful for generating code files.
---
src/runtime/runtime.pkg | 3 +
src/runtime/savres.scm | 35 +-------
src/runtime/version.scm | 172 +++++++++++++++++++++++++++++++++++++++-
3 files changed, 176 insertions(+), 34 deletions(-)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 130504572..4058fc31b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -60,6 +60,9 @@ USA.
(define-package (runtime)
(files "version")
(parent ())
+ (export ()
+ write-mit-scheme-copyright
+ write-mit-scheme-license)
(initialization (initialize-package!)))
(define-package (runtime bit-string)
diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm
index 91d308f4e..86073fc5e 100644
--- a/src/runtime/savres.scm
+++ b/src/runtime/savres.scm
@@ -124,34 +124,9 @@ USA.
(if (default-object? port)
(current-output-port)
(guarantee-output-port port 'IDENTIFY-WORLD))))
- (let ((strings
- `("Copyright (C)"
- ,@(let loop ((ys copyright-years))
- (if (pair? (cdr ys))
- (cons (string-append (number->string (car ys)) ",")
- (loop (cdr ys)))
- (list (number->string (car ys)))))
- "Massachusetts"
- "Institute"
- "of"
- "Technology")))
- (write-string (car strings) port)
- (let loop
- ((strings (cdr strings))
- (col (string-length (car strings))))
- (if (pair? strings)
- (let ((col* (+ col 1 (string-length (car strings)))))
- (if (<= col* 70)
- (begin
- (write-string " " port)
- (write-string (car strings) port)
- (loop (cdr strings) col*))
- (begin
- (newline port)
- (write-string " " port)
- (loop strings 0)))))))
+ (write-mit-scheme-copyright port)
(newline port)
- (write-string license-statement port)
+ (write-mit-scheme-license port "" #t)
(newline port)
(newline port)
(if time-world-saved
@@ -169,8 +144,4 @@ USA.
1
" "
" || "
- "")))
-
-(define license-statement
- "This is free software; see the source for copying conditions. There is NO
-warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.")
\ No newline at end of file
+ "")))
\ No newline at end of file
diff --git a/src/runtime/version.scm b/src/runtime/version.scm
index 5af50a976..9b815e8da 100644
--- a/src/runtime/version.scm
+++ b/src/runtime/version.scm
@@ -34,7 +34,7 @@ USA.
(define (initialize-package!)
(set! copyright-years
- (let ((now 2008)
+ (let ((now 2009)
(then 1986))
(iota (+ (- now then) 1) then)))
(add-subsystem-identification! "Release" '(7 7 90 "+"))
@@ -44,4 +44,172 @@ USA.
(define (snarf-microcode-version!)
(add-subsystem-identification! "Microcode"
- (get-microcode-version-numbers)))
\ No newline at end of file
+ (get-microcode-version-numbers)))
+
+(define (write-mit-scheme-copyright #!optional port line-prefix cmark)
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port 'WRITE-MIT-SCHEME-COPYRIGHT)))
+ (cmark (if (default-object? cmark) "(C)" cmark))
+ (line-prefix (if (default-object? line-prefix) "" line-prefix)))
+ (write-words (let ((years (map number->string copyright-years)))
+ `("Copyright"
+ ,cmark
+ ,@(map (lambda (s) (string-append s ","))
+ (except-last-pair years))
+ ,(last years)
+ "Massachusetts"
+ "Institute"
+ "of"
+ "Technology"))
+ line-prefix
+ " "
+ port)))
+
+(define (write-mit-scheme-license #!optional port line-prefix short?)
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port 'WRITE-MIT-SCHEME-LICENSE)))
+ (line-prefix (if (default-object? line-prefix) "" line-prefix))
+ (short? (if (default-object? short?) #f short?)))
+ (let loop
+ ((paragraphs
+ (split-paragraphs
+ (if short?
+ short-license-statement
+ long-license-statement))))
+ (write-words (car paragraphs) line-prefix "" port)
+ (if (pair? (cdr paragraphs))
+ (begin
+ (newline port)
+ (write-string (string-trim-right line-prefix) port)
+ (newline port)
+ (loop (cdr paragraphs)))))))
+
+(define long-license-statement
+ "This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.")
+
+(define short-license-statement
+ "This is free software; see the source for copying conditions. There is NO
+warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.")
+
+(define (split-paragraphs text)
+ (let loop ((lines (split-into-lines text)) (paras '()))
+ (receive (lines para) (next-paragraph lines)
+ (if para
+ (loop lines (cons para paras))
+ (reverse! paras)))))
+
+(define (next-paragraph lines)
+ (let loop ((lines (skip-blank-lines lines)) (para '()))
+ (if (and (pair? lines)
+ (not (blank-line? (car lines))))
+ (loop (cdr lines) (cons (car lines) para))
+ (values lines
+ (if (pair? para)
+ (append-map! split-text-words (reverse! para))
+ #f)))))
+
+(define (skip-blank-lines lines)
+ (if (and (pair? lines)
+ (blank-line? (car lines)))
+ (skip-blank-lines (cdr lines))
+ lines))
+
+(define (blank-line? line)
+ (string-null? (string-trim line)))
+
+(define (split-into-lines text)
+ (let ((input (open-input-string text)))
+ (let loop ((lines '()))
+ (let ((line (read-line input)))
+ (if (eof-object? line)
+ (reverse! lines)
+ (loop (cons line lines)))))))
+
+(define (split-text-words text)
+ (let ((end (string-length text)))
+
+ (define (loop i words)
+ (let ((i (skip-white i)))
+ (if (fix:< i end)
+ (let ((j (skip-non-white i)))
+ (loop j
+ (cons (substring text i j) words)))
+ words)))
+
+ (define (skip-white i)
+ (if (and (fix:< i end)
+ (char-set-member? char-set:whitespace (string-ref text i)))
+ (skip-white (fix:+ i 1))
+ i))
+
+ (define (skip-non-white i)
+ (if (and (fix:< i end)
+ (not (char-set-member? char-set:whitespace
+ (string-ref text i))))
+ (skip-non-white (fix:+ i 1))
+ i))
+
+ (reverse! (loop 0 '()))))
+
+(define (write-words words line-prefix indentation port)
+ (let ((wrap-column (- (output-port/x-size port) 5))
+ (space " "))
+
+ (define (write-first-word words indent?)
+ (write-string line-prefix port)
+ (if indent? (write-string indentation port))
+ (write-string (car words) port)
+ (write-rest-words (cdr words)
+ (new-column 0
+ line-prefix
+ (if indent? indentation "")
+ (car words))))
+
+ (define (write-rest-words words column)
+ (if (pair? words)
+ (let ((column* (new-column column space (car words))))
+ (if (<= column* wrap-column)
+ (begin
+ (write-string space port)
+ (write-string (car words) port)
+ (write-rest-words (cdr words) column*))
+ (begin
+ (newline port)
+ (write-first-word words #t))))))
+
+ (write-first-word words #f)))
+
+(define (new-column column . strings)
+ (let loop ((column column) (strings strings))
+ (if (pair? strings)
+ (loop (let ((string (car strings)))
+ (let ((end (string-length string)))
+ (do ((i 0 (fix:+ i 1))
+ (column column
+ (fix:+ column
+ (let ((c (string-ref string i)))
+ (if (char=? c #\tab)
+ (fix:- 8 (fix:remainder column 8))
+ 1)))))
+ ((not (fix:< i end)) column))))
+ (cdr strings))
+ column)))
\ No newline at end of file
--
2.25.1