home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / makegen / makegen.scm < prev    next >
Text File  |  2000-12-05  |  6KB  |  193 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: makegen.scm,v 1.2 2000/12/05 21:23:50 cph Exp $
  4.  
  5. Copyright (c) 2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Generate "Makefile.in" from template.
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (load-option 'REGULAR-EXPRESSION)
  27. (load-option 'SYNCHRONOUS-SUBPROCESS)
  28.  
  29. (define (generate-makefile template deps-filename makefile)
  30.   (let ((file-lists
  31.      (map (lambda (pathname)
  32.         (cons (pathname-name pathname)
  33.               (read-file pathname)))
  34.           (list-transform-positive (directory-read "makegen/")
  35.         (lambda (pathname)
  36.           (re-string-match "^files-.+\\.scm$"
  37.                    (file-namestring pathname)))))))
  38.     (call-with-input-file template
  39.       (lambda (input)
  40.     (call-with-output-file makefile
  41.       (lambda (output)
  42.         (write-string "# This file automatically generated from " output)
  43.         (write-string (file-namestring template) output)
  44.         (newline output)
  45.         (write-string "# on " output)
  46.         (write-string (universal-time->string (get-universal-time)) output)
  47.         (write-string "." output)
  48.         (newline output)
  49.         (newline output)
  50.         (let loop ((column 0))
  51.           (let ((char (read-char input)))
  52.         (if (not (eof-object? char))
  53.             (if (and (char=? #\@ char)
  54.                  (eqv? #\( (peek-char input)))
  55.             (let ((command (read input)))
  56.               (if (eqv? #\@ (peek-char input))
  57.                   (read-char input)
  58.                   (error "Missing @ at end of command:" command))
  59.               (loop (interpret-command command column
  60.                            file-lists deps-filename
  61.                            output)))
  62.             (begin
  63.               (write-char char output)
  64.               (loop
  65.                (if (char=? #\newline char)
  66.                    0
  67.                    (+ column 1))))))))))))))
  68.  
  69. (define (interpret-command command column file-lists deps-filename output)
  70.   (let ((malformed (lambda () (error "Malformed command:" command))))
  71.     (if (not (and (pair? command)
  72.           (symbol? (car command))
  73.           (list? (cdr command))))
  74.     (malformed))
  75.     (let ((guarantee-nargs
  76.        (lambda (n)
  77.          (if (not (= n (length (cdr command))))
  78.          (malformed)))))
  79.       (let ((write-suffixed
  80.          (lambda (suffix)
  81.            (guarantee-nargs 1)
  82.            (let ((entry (assoc (cadr command) file-lists)))
  83.          (if (not entry)
  84.              (malformed))
  85.          (write-items (map (lambda (file) (string-append file suffix))
  86.                    (cdr entry))
  87.                   column
  88.                   output)
  89.          0))))
  90.       (case (car command)
  91.     ((WRITE-SOURCES)
  92.      (write-suffixed ".c"))
  93.     ((WRITE-OBJECTS)
  94.      (write-suffixed ".o"))
  95.     ((WRITE-DEPENDENCIES)
  96.      (guarantee-nargs 0)
  97.      (write-dependencies file-lists deps-filename output))
  98.     (else
  99.      (error "Unknown command:" command)))))))
  100.  
  101. (define (write-dependencies file-lists deps-filename output)
  102.   (maybe-update-dependencies
  103.    deps-filename
  104.    (sort (append-map (lambda (file-list)
  105.                (map (lambda (base) (string-append base ".c"))
  106.                 (cdr file-list)))
  107.              file-lists)
  108.      string<?))
  109.   (call-with-input-file deps-filename
  110.     (lambda (input)
  111.       (let ((buffer (make-string 4096)))
  112.     (let loop ()
  113.       (let ((n (read-substring! buffer 0 4096 input)))
  114.         (if (> n 0)
  115.         (begin
  116.           (write-substring buffer 0 n output)
  117.           (loop)))))))))
  118.  
  119. (define (maybe-update-dependencies deps-filename source-files)
  120.   (if (let ((mtime (file-modification-time deps-filename)))
  121.     (or (not mtime)
  122.         (there-exists? source-files
  123.           (lambda (source-file)
  124.         (> (file-modification-time source-file) mtime)))))
  125.       (let ((rules (map generate-rule source-files)))
  126.     (call-with-output-file deps-filename
  127.       (lambda (output)
  128.         (let loop ((rules rules))
  129.           (if (pair? rules)
  130.           (begin
  131.             (write-rule (car rules) output)
  132.             (if (pair? (cdr rules))
  133.             (begin
  134.               (newline output)
  135.               (loop (cdr rules))))))))))))
  136.  
  137. (define (generate-rule filename)
  138.   (parse-rule
  139.    (unbreak-lines
  140.     (with-string-output-port
  141.       (lambda (port)
  142.     (run-shell-command (string-append "gcc -M " filename)
  143.                'OUTPUT port))))))
  144.  
  145. (define (unbreak-lines string)
  146.   (let ((indexes (string-search-all "\\\n" string)))
  147.     (let ((n (length indexes))
  148.       (end (string-length string)))
  149.       (let ((result (make-string (- end (* 2 n)))))
  150.     (let loop ((start 0) (indexes indexes) (rstart 0))
  151.       (if (pair? indexes)
  152.           (begin
  153.         (substring-move! string start (car indexes) result rstart)
  154.         (loop (+ (car indexes) 2)
  155.               (cdr indexes)
  156.               (+ rstart (- (car indexes) start))))
  157.           (substring-move! string start end result rstart)))
  158.     result))))
  159.  
  160. (define (parse-rule rule)
  161.   (let ((items (burst-string rule char-set:whitespace #t)))
  162.     (if (not (string-suffix? ":" (car items)))
  163.     (error "Missing rule target:" rule))
  164.     (cons* (string-head (car items) (- (string-length (car items)) 1))
  165.        (cadr items)
  166.        (sort (list-transform-negative (cddr items) pathname-absolute?)
  167.          string<?))))
  168.  
  169. (define (write-rule rule port)
  170.   (write-string (car rule) port)
  171.   (write-string ": " port)
  172.   (write-items (cdr rule) (+ (string-length (car rule)) 2) port))
  173.  
  174. (define (write-items items start-column port)
  175.   (let loop ((items* items) (column start-column))
  176.     (if (pair? items*)
  177.     (let ((column
  178.            (if (eq? items* items)
  179.            column
  180.            (begin
  181.              (write-string " " port)
  182.              (+ column 1))))
  183.           (delta (string-length (car items*))))
  184.       (let ((new-column (+ column delta)))
  185.         (if (>= new-column 78)
  186.         (begin
  187.           (write-string "\\\n\t" port)
  188.           (write-string (car items*) port)
  189.           (loop (cdr items*) (+ 8 delta)))
  190.         (begin
  191.           (write-string (car items*) port)
  192.           (loop (cdr items*) new-column)))))
  193.     column)))