From 645587e343ef1f3961fa6f2f0ba08af0bdeddb64 Mon Sep 17 00:00:00 2001 From: Chris Hanson 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