scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

examples: a small c program to be build through makefile-c.scm 

to-rule-set: rule-candidates -> dfs -> '(#{:rule} ...) -> rule-set

dfs:      depth first topological sort with automatic leaf insertion

out-of-date: replaced by templates.scm

rule-trans-set: replaced by to-rule-set
This commit is contained in:
jottbee 2005-02-04 08:05:55 +00:00
parent 5b462916b1
commit a8dd2ab60b
20 changed files with 1182 additions and 372 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
SYNTAX Normal file
View File

@ -0,0 +1,59 @@
MAKEFILE:
=========
<makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
<makerule-clause> ::= <rule-clause>
| <md5-clause>
| <always-clause>
| <once-clause>
<rule-clause> ::= '(' + <rule-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<md5-clause> ::= '(' + <md5-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<always-clause> ::= '(' + <always-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<once-clause> ::= '(' + <once-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<rule-clause-identifier> ::= "rule"
| "makefile-rule"
| "is-out-of-date?"
<md5-clause-identifier> ::= "md5"
| "rule-md5"
| "fp-changed?"
<always-clause-identifier> ::= "always"
| "rule-always"
| "phony"
| "is-out-of-date!"
<once-clause-identifier> ::= "once"
| "rule-once"
<target-spec> ::= <target> | <target-list>
<target> ::= <filename>
<target-list> ::= '(' + <filename>+ + ')'
<prereq-spec> ::= <prereq> | <prereq-list>
<prereq> ::= <filename>
<prereq-list> ::= '(' + <filename>* + ')'
<action-spec> ::= <action> | <action-list>
<action> ::= '(' + <thunk>* + ')'
<action-list> ::= '(' + <action>+ + ')'
<filename> ::= '"' + {<dir-separator> + { 'a'-'z''A'-'Z''0'-'9' ... }+ }+ + '"'

230
dfs.scm
View File

@ -1,100 +1,172 @@
(define time 0)
(define-enumerated-type color :color
is-color?
the-color
the-colors
color-name
color-index
(white grey black))
;;;
;;; DFS:
;;; ====
;;;
;;; (make-dfs node-name adjacencies ignored-data) ---> #{:dfs}
;;;
;;; node-name : "this is a node name"
;;; adjacencies : (list "another node name" "no node name")
;;; ignored-data : "anything you need in each node, eg. a long list..."
;;;
;;; (dfs->list node) ---> '(node-name adjacencies ignored-data)
;;;
;;; node : #{:dfs}
;;;
;;; (dfs-name node) ---> node-name
;;; (dfs-adjacencies node) ---> adjacencies
;;; (dfs-color node) ---> #{:color}
;;; (dfs-ftime node) ---> finishing-time
;;; (dfs-ignored node) ---> ignored-data
;;;
(define-record-type :dfs
(really-make-dfs node adjacencies color predec dtime ftime ignored-data)
(really-make-dfs name adjacencies color ftime ignored)
is-dfs?
(node dfs-node)
(name dfs-name)
(adjacencies dfs-adjacencies)
;; color (white by default)
(color dfs-color)
;; predecessor (is #f by default)
(predec dfs-predec)
;; discovery-time
(dtime dfs-dtime)
;; finishing-time
(ftime dfs-ftime)
;; thie is for all node specific information
;; and is ignore by the dfs algorithm
;; put in there what you like
(ignored-data dfs-ignored-data))
(ignored dfs-ignored))
(define (make-dfs node adjacencies ignored-data)
(really-make-dfs node adjacencies (color white) 0 0 #f ignored-data))
(define (make-dfs node-name adjacencies ignored-data)
(really-make-dfs node-name adjacencies (color white) 0 ignored-data))
(define (dfs->list dfs)
(list (dfs-node dfs) (dfs-adjacencies dfs) (dfs-ignored-data dfs)))
(define (dfs->list dfs-node)
(list (dfs-name dfs-node) (dfs-adjacencies dfs-node) (dfs-ignored dfs-node)))
(define (dfs-timer ch)
(spawn
(lambda ()
(let timer-loop ((current-time 0))
(cml-sync-ch/receive ch)
(cml-sync-ch/send ch current-time)
(timer-loop (+ current-time 1))))))
(define (dfs-lookup-node node-name dag)
(find (lambda (candidate)
(string=? (dfs-name candidate) node-name))
dag))
(define (dfs-time ch)
(cml-sync-ch/send ch 'get-time)
(cml-sync-ch/receive ch))
;;;
;;; DEPTH FIRST SEARCH:
;;; ===================
;;;
;;; (dfs dag) ---> sorted-dag
;;; (dfs dag auto-leafs?) ---> sorted-dag
;;;
;;; where
;;;
;;; dag : '(#{:dfs} ...)
;;; auto-leafs? : #t (by default) or #f
;;; sorted-dag : the sorted dag
;;;
;;; auto-leafs?:
;;;
;;; if auto-leafs? is enabled then every adjacency which is unresolveable
;;; in the set of all node-names is assumed to point to a leaf.
;;; this leaf is then created automatically: it consists of the node-name
;;; which was given by the initiating adjencency, the empty adjacencies
;;; list, and the ignored-data-field set to #f.
;;; if auto-leafs? is set to #f then it is an error that an adjacency is
;;; unresolveable in the list of all node-names.
;;;
(define (dfs dag . maybe-arg)
(let-optionals maybe-arg ((auto-leafs? #t))
(set! time 0)
(let ((node-names (map dfs-name dag)))
(if (not (null? node-names))
;; (sort pred todo-list done-list)
(sort (lambda (current position)
(< (dfs-ftime current) (dfs-ftime position)))
;;
;; the result of this should be the dag with the ftimes
;;
(let for-all-nodes ((node-name (car node-names))
(nodes-to-do (cdr node-names))
(current-dag dag))
(let ((current-node (dfs-lookup-node node-name current-dag)))
(cond
((eq? (dfs-color current-node) (color white))
(let ((new-dag (dfs-visit current-dag
current-node auto-leafs?)))
(if (not (null? nodes-to-do))
(for-all-nodes (car nodes-to-do)
(cdr nodes-to-do)
new-dag)
new-dag)))
(else (if (not (null? nodes-to-do))
(for-all-nodes (car nodes-to-do)
(cdr nodes-to-do)
current-dag)
current-dag)))))
'())
node-names))))
(define (dfs-lookup-adjs dag adj)
(let ((maybe-rc ))
(if maybe-rc maybe-rc
(define (dfs-visit dag node auto-leafs?)
;; (dfs-dag-show dag node)
(let ((name (dfs-name node))
(adjs (dfs-adjacencies node))
(ignored (dfs-ignored node)))
(let* ((current-node (really-make-dfs name adjs (color grey)
(dfs-ftime node) ignored))
(current-dag (cons current-node (delete node dag))))
(if (not (null? adjs))
(let for-all-adjs ((current-adj (car adjs))
(todo-adjs (cdr adjs)))
(let ((maybe-node (dfs-lookup-node current-adj current-dag)))
(if maybe-node
(begin
(if (eq? (dfs-color maybe-node) (color white))
(let ((next-dag (dfs-visit current-dag
maybe-node auto-leafs?)))
(set! current-dag next-dag))
(if (eq? (dfs-color maybe-node) (color grey))
(error "dfs-visit: cycle detected; node-name: "
(dfs-name node)))))
(if auto-leafs?
(let ((leaf (really-make-dfs current-adj '()
(color white) 0 #f)))
(set! current-dag (dfs-visit (cons leaf current-dag)
leaf auto-leafs?)))
(error "dfs-visit: incomplete dag!"))))
(if (not (null? todo-adjs))
(for-all-adjs (car todo-adjs) (cdr todo-adjs)))))
(set! time (+ time 1))
(cons (really-make-dfs name adjs (color black) time ignored)
(delete current-node current-dag)))))
(define (dfs-visit dag node time-ch)
(set! (dfs-color node) (color grey))
(set! (dfs-dtime node) (dfs-time time-ch))
(for-each (lambda (adj)
(cond
((eq? (dfs-color adj) (color white))
(begin
(set! (dfs-predecessor adj) node)
(dfs-visit adj time-ch)))
;;
;; ((eq? (dfs-color adj) (color black))
;; "already been here")
;;
((eq? (dfs-color adj) (color grey))
(error "dfs-visit: cycle detected!"))))
;; this should be the list of all adjacency-nodes
;; this is done by map over all adjacencies
;; lookup each adj in dag, check if its node-name is adj
(map (lambda (adj)
(find (lambda (candidate)
(eq? (dfs-node candidate) adj))
dag))
(dfs-adjs node)))
(set! (dfs-color node) (color black))
(set! (dfs-ftime node) (dfs-time time-ch)))
;;; this is the depth first search algorithm
;;; dag is a list of nodes of record-type dfs
(define (dfs dag)
(let* ((time-ch (cml-sync-ch/make-channel))
(start-timer (dfs-timer time-ch)))
(define (dfs-dag-show dag node)
(newline) (newline) (newline) (newline)
(display "************************************************************\n")
(display (dfs-name node)) (newline)
(display "************************************************************\n")
(let ((dfs-node-show (lambda (node)
(newline)
(display "~dfs-name: ")
(display (dfs-name node))
(newline)
(display "~dfs-adjacencies: ")
(display (dfs-adjacencies node))
(newline)
(display "~dfs-color: ")
(display (dfs-color node))
(newline)
(display "~dfs-ftime: ")
(display (dfs-ftime node))
(newline)
(display "~dfs-ignored: ")
(display (dfs-ignored node))
(newline))))
(if (not (null? dag))
(begin
(let visit-each-node ((current-node (car dag))
(nodes-to-do (cdr dag)))
(if (eq? (dfs-color current-node) (color white))
(dfs-visit dag current-node time-ch))
(if (not (null? nodes-to-do))
(visit-each-node (car nodes-to-do) (cdr nodes-to-do))))
;; now sort field (dfs-ftime node) in descendent order
...
))))
(define (dfs-sort-insert pred item queue)
(cond
((null? queue) (cons item))
((not (pred item (car queue))) (cons item queue))
(else (dfs-sort-insert item (cdr queue)))))
(define (dfs-sort pred todo done)
(if (null? todo)
done
(dfs-sort pred (cdr todo) (dfs-sort-insert pred (car todo) done))))
(let visit-each-node ((current-node (car dag))
(nodes-to-do (cdr dag)))
(dfs-node-show current-node)
(if (not (null? nodes-to-do))
(visit-each-node (car nodes-to-do) (cdr nodes-to-do))
(begin
(display "************************************************************\n")
(display "************************************************************\n")
(newline) (newline) (newline) (newline)))))))

31
examples/README Normal file
View File

@ -0,0 +1,31 @@
Starting make:
==============
In XEmacs open a new buffer to edit this makefile-c.scm. Make sure you
had no active scheme-buffer. This will have the effect that your
current working directory is the one with makefile-c.scm in it. Now
open a new scheme-buffer with 'M-x run-scheme'. You should have passed
(at least) the following arguments to scsh:
'scsh -lel cml/load.scm -lel concurrency/load.scm'
Now load the packages.scm file into package config:
> ,config ,load ../packages.scm
Open the structures macros and make in package user:
> ,open macros make
Load makefile-c.scm:
> ,load makefile-c.scm
Start make:
> (make rule-set (list "test"))
This should start a build all, install, and test installation process.
By default, the installation directory will be ../../image.
Have fun.

3
examples/checksums.md5 Normal file
View File

@ -0,0 +1,3 @@
71537751982895759163390057694999171418 config.h
14291919577004468625754235508931697268 mymath.c
277010555671960749526965727376092322885 manual.tex

3
examples/config.h Normal file
View File

@ -0,0 +1,3 @@
#ifndef MY_DELTA_MAX
#define MY_DELTA_MAX 0.00000000000001
#endif

44
examples/main.c Normal file
View File

@ -0,0 +1,44 @@
#include "wildio.h"
#include "mymath.h"
#include <dlfcn.h>
#include <stdio.h>
double magic_number = 0.0;
int main(int argc, char** argv) {
void *libwildio;
int (*show_a_double_call)(double);
double (*checkargs_call)(int,char**);
void *libmymath;
double (*sqrt_call)(double), result;
dlerror();
if (libwildio=dlopen("libwildio.so.1",RTLD_LAZY))
{
checkargs_call = dlsym(libwildio,"checkargs");
show_a_double_call = dlsym(libwildio,"show_a_double");
/* magic_number will be set by checkargs */
magic_number = (*checkargs_call)(argc,argv);
if (libmymath=dlopen("libmymath.so.1",RTLD_LAZY)) {
sqrt_call = dlsym(libmymath,"sqrt");
magic_number = (*sqrt_call)(magic_number);
result = (*show_a_double_call)(magic_number);
dlclose(libmymath);
dlclose(libwildio);
return result;
}
}
/* last exit */
exit(1);
}

253
examples/makefile-c.scm Normal file
View File

@ -0,0 +1,253 @@
(define image-dir "../../image")
(define prefix (string-append image-dir "/" "usr"))
(define my-lib-dir (string-append prefix "/" "lib"))
(define my-bin-dir (string-append prefix "/" "bin"))
(define my-share-dir (string-append prefix "/" "share"))
(define my-doc-dir (string-append my-share-dir "/" "doc"))
(define my-install-doc-dir (string-append my-doc-dir "/" "show-sqrt-1.0"))
(define clean-files
(list "wildio.o" "mymath.o"
"libwildio.so.1.0" "libmymath.so.1.0"
"libwildio.so.1" "libmymath.so.1"
"libwildio.so" "libmymath.so"
"show-sqrt"
"manual.dvi" "manual.pdf" "manual.log" "manual.aux"))
(define rule-set
(makefile
;;
;; build libmymath.*
;;
(md5 "mymath.o"
("config.h" "mymath.c")
(lambda ()
(run (gcc -fPIC -c ,"mymath.c"))))
(rule "libmymath.so.1.0"
("mymath.o")
(lambda ()
(run (gcc -shared ,"-Wl,-soname,libmymath.so.1"
-o ,"libmymath.so.1.0" ,"mymath.o"))))
;;
;; build wildio.*
;;
(rule "wildio.o"
("wildio.c")
(lambda ()
(run (gcc -fPIC -c ,"wildio.c"))))
(rule "libwildio.so.1.0"
("wildio.o")
(lambda ()
(run (gcc -shared "-Wl,-soname,libwildio.so.1"
-o ,"libwildio.so.1.0" ,"wildio.o"))))
;;
;; build the program
;;
(rule "show-sqrt"
("libmymath.so.1" "libwildio.so.1" "main.c" "wildio.h" "mymath.h")
(lambda ()
(run (gcc -L ,"." -L ,my-lib-dir -rdynamic
-o ,(expand-file-name "show-sqrt" (cwd))
,(expand-file-name "main.c" (cwd))
,(expand-file-name "libwildio.so.1" (cwd))
,(expand-file-name "libmymath.so.1" (cwd)) -ldl))))
;;
;; install libs
;;
(rule "libmymath.so.1"
("libmymath.so.1.0")
(lambda ()
(create-symlink "libmymath.so.1.0" "libmymath.so.1")))
(rule "libmymath.so"
("libmymath.so.1")
(lambda ()
(create-symlink "libmymath.so.1" "libmymath.so")))
(rule "libwildio.so.1"
("libwildio.so.1.0")
(lambda ()
(create-symlink "libwildio.so.1.0" "libwildio.so.1")))
(rule "libwildio.so"
("libwildio.so.1")
(lambda ()
(create-symlink "libwildio.so.1" "libwildio.so")))
(rule (string-append my-lib-dir "/" "libmymath.so.1")
((string-append my-lib-dir "/" "libmymath.so.1.0"))
(lambda ()
(with-cwd my-lib-dir
(create-symlink "libmymath.so.1.0" "libmymath.so.1"))))
(rule (string-append my-lib-dir "/" "libmymath.so")
((string-append my-lib-dir "/" "libmymath.so.1"))
(lambda ()
(with-cwd my-lib-dir
(create-symlink "libmymath.so.1" "libmymath.so"))))
(rule (string-append my-lib-dir "/" "libwildio.so.1")
((string-append my-lib-dir "/" "libwildio.so.1.0"))
(lambda ()
(with-cwd my-lib-dir
(create-symlink "libwildio.so.1.0" "libwildio.so.1"))))
(rule (string-append my-lib-dir "/" "libwildio.so")
((string-append my-lib-dir "/" "libwildio.so.1"))
(lambda ()
(with-cwd my-lib-dir
(create-symlink "libwildio.so.1" "libwildio.so"))))
(rule (string-append my-lib-dir "/" "libwildio.so.1.0")
(my-lib-dir "libwildio.so.1.0")
(lambda ()
(run (cp ,"libwildio.so.1.0"
,(string-append my-lib-dir "/" "libwildio.so.1.0")))))
(rule (string-append my-lib-dir "/" "libmymath.so.1.0")
(my-lib-dir "libmymath.so.1.0")
(lambda ()
(run (cp ,"libmymath.so.1.0"
,(string-append my-lib-dir "/" "libmymath.so.1.0")))))
;;
;; install the program
;;
(rule (string-append my-bin-dir "/" "show-sqrt")
(my-bin-dir "show-sqrt")
(lambda ()
(run (cp ,"show-sqrt"
,(string-append my-bin-dir "/" "show-sqrt")))))
;;
;; build the manual
;;
(md5 "manual.dvi"
("manual.tex")
(lambda ()
(run (latex ,"manual.tex"))))
(rule "manual.pdf"
("manual.dvi")
(lambda ()
(run (dvipdfm -o ,"manual.pdf" ,"manual.dvi"))))
;;
;; install the manual
;;
(rule (string-append my-install-doc-dir "/" "manual.pdf")
(my-install-doc-dir "manual.pdf")
(lambda ()
(run (cp "manual.pdf"
,(string-append my-install-doc-dir "/" "manual.pdf")))))
;;
;; install all
;;
(rule "install"
((string-append my-lib-dir "/" "libmymath.so.1.0")
(string-append my-lib-dir "/" "libwildio.so.1.0")
(string-append my-lib-dir "/" "libmymath.so.1")
(string-append my-lib-dir "/" "libwildio.so.1")
(string-append my-lib-dir "/" "libmymath.so")
(string-append my-lib-dir "/" "libwildio.so")
(string-append my-bin-dir "/" "show-sqrt")
(string-append my-install-doc-dir "/" "manual.pdf"))
(lambda ()
(display "install done.\n")))
;;
;; create checksums.md5
;;
(once "checksums.md5"
("manual.tex" "main.c" "mymath.c"
"mymath.h" "wildio.c" "wildio.h" "config.h")
(lambda ()
(let ((outport (open-output-file (expand-file-name "checksums.md5"
(cwd)))))
(with-current-output-port outport (display ""))
(close-output-port outport))))
(rule "config.h"
()
(lambda ()
(let ((outport (open-output-file
(expand-file-name "config.h" (cwd)))))
(with-current-output-port
outport
(display "#ifndef MY_DELTA_MAX\n")
(display "#define MY_DELTA_MAX 0.000000001\n")
(display "#endif\n")
(close-output-port outport)))))
;;
;; clean rules
;;
(always "clean"
()
(lambda ()
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
clean-files)))
;;
;; clean rules
;;
(always "mrproper"
("clean")
(lambda ()
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
(list "checksums.md5"))))
;;
;; uninstall all
;;
(always "uninstall"
()
(lambda ()
(display "uninstall: \n")
(for-each (lambda (f)
(delete-filesys-object f))
(list (string-append my-lib-dir "/" "libmymath.so.1.0")
(string-append my-lib-dir "/" "libwildio.so.1.0")
(string-append my-lib-dir "/" "libmymath.so.1")
(string-append my-lib-dir "/" "libwildio.so.1")
(string-append my-lib-dir "/" "libmymath.so")
(string-append my-lib-dir "/" "libwildio.so")
(string-append my-bin-dir "/" "show-sqrt")
(string-append my-install-doc-dir "/" "manual.pdf")
my-install-doc-dir
my-doc-dir
my-share-dir
my-lib-dir
my-bin-dir
prefix
image-dir))
(display "uninstall done.\n")))
;;
;; install dirs
;;
(once image-dir
()
(lambda ()
(create-directory image-dir)))
(once prefix
(image-dir)
(lambda ()
(create-directory prefix)))
(once my-lib-dir
(prefix)
(lambda ()
(create-directory my-lib-dir)))
(once my-bin-dir
(prefix)
(lambda ()
(create-directory my-bin-dir)))
(once my-share-dir
(prefix)
(lambda ()
(create-directory my-share-dir)))
(once my-doc-dir
(my-share-dir)
(lambda ()
(create-directory my-doc-dir)))
(once my-install-doc-dir
(my-doc-dir)
(lambda ()
(create-directory my-install-doc-dir)))
;;
;; a small test
;;
(always "test"
("install")
(lambda ()
(let ((proggy (expand-file-name "show-sqrt" my-bin-dir)))
(display "testing ") (display proggy) (newline)
(setenv "LD_LIBRARY_PATH" my-lib-dir)
(display "# sqrt 2.0:\n")
(run (,proggy ,"2.0"))
(display "# sqrt 5.0:\n")
(run (,proggy ,"5.0"))
(display "ok.\n"))))))

19
examples/manual.tex Normal file
View File

@ -0,0 +1,19 @@
\documentclass[a4paper]{report}
\usepackage[dvipdfm,hyperindex,hypertex,
pdftitle={show-sqrt manual, release 1.0},
pdfauthor={Johannes Brügmann}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue,
pdfstartview=FitW,pdfview=FitW]{hyperref}
\usepackage{charter}
\author{Real A. Name}
\title{show-sqrt rel. 1.0 manual}
\begin{document}
\maketitle
This is the show-sqrt release 1.0 manual.
show-sqrt comes with a single feature: It calculates the square root
of a passed as an argument given positive double value and prints the
result on screen (stdout).
Have fun.
\end{document}

28
examples/mymath.c Normal file
View File

@ -0,0 +1,28 @@
#include "config.h"
double positive (double x) {
if (x > 0.0)
return x;
else
return 0.0 - x;
}
double sqrt (double a) {
double x_old = 1.0, x_new = 0.5;
if (a > 0.0) {
do {
x_old = x_new;
x_new = ((a / x_old) + x_old) / 2.0;
} while (positive(x_old - x_new) > MY_DELTA_MAX);
return x_new;
} else exit(1);
}

1
examples/mymath.h Normal file
View File

@ -0,0 +1 @@
double sqrt (double a);

28
examples/wildio.c Normal file
View File

@ -0,0 +1,28 @@
#include <stdio.h>
#include <errno.h>
int show_a_double (double x) {
printf(">> double: %09.15f\n", x);
}
int usage(char *progname) {
char *str;
printf("usage: %s <double-value>\n", progname);
exit(ENOTSUP);
}
int checkargs(int argc, char *argv[]) {
double darg = 0.0;
if (argc != 2) usage((char *const) argv[0]);
else darg = atof(argv[1]);
return darg;
}

2
examples/wildio.h Normal file
View File

@ -0,0 +1,2 @@
int show_a_double (double x);
int checkargs(int argc, char *argv[]);

243
macros.scm
View File

@ -1,132 +1,157 @@
;;; TODO:
;;;
;;; macros -> functions, eg.
;;;
;;; (define make-is-out-of-date!
;;; (lambda (t . p)
;;; (lambda args (cons #t (last args)))))
(define-syntax make
(syntax-rules ()
((make ?rule-trans-set (?target-fname0 ...) ?init-state)
;;
;; ?rule-trans-set or ?target-fname0 could be an expr: eval only once
;;
(let ((rule-trans-set (known-rules-update ?rule-trans-set)))
(let* ((target-fname0 ?target-fname0)
(target-rule (known-rules-get rule-trans-set target-fname0)))
(if (not (null? (rule-trans-set-rule-candidates rule-trans-set)))
(display "rule-candidates not empty.\n"))
(if target-rule
(rule-make target-rule
?init-state
(rule-trans-set-rule-set rule-trans-set))
(error "target-rule not found in rule-set.")))
...))
((_ )
(error "usage: (make '#{:rule-trans-set} (target0 ...) init-state)\n"))))
;;; MAKEFILE:
;;; =========
;;; (define-syntax makefile
;;; (syntax-rules ()
;;; ((makefile ?rule0 ...)
;;; (let ((rule-trans-set (make-empty-rule-trans-set)))
;;; (let* ((rule-trans-set (?rule0 rule-trans-set))
;;; (let ((rule-candidates '()))
;;; (let* ((rule-candidates (?rule0 rule-candidates))
;;; ...)
;;; rule-trans-set)))))
;;; rule-candidates)))))
;;;
;;; <makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
;;; <makerule-clause> ::= <rule-clause>
;;; | <md5-clause>
;;; | <always-clause>
;;; | <once-clause>
;;;
;;;
(define-syntax makefile
(syntax-rules ()
((makefile) (make-empty-rule-trans-set))
((makefile ?rule0 ?rule1 ...)
(?rule0 (makefile ?rule1 ...)))))
((makefile) (list))
((makefile ?rule0 ?rule1 ...) (?rule0 (makefile ?rule1 ...)))))
;;;
;;; <rule-clause>
;;;
;;; to achieve consistency only rule will use the rule-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax makefile-rule
(syntax-rules ()
((makefile-rule ?target (?prereq0 ...) ?thunk)
(makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
((makefile-rule ?target ?prereqs ?thunk) (rule ?target ?prereqs ?thunk))))
(define-syntax makefile-rule-tmpvars
(define-syntax is-out-of-date?
(syntax-rules ()
((makefile-rule-tmpvars (tmp1 ...) ?target () ?thunk)
;;
;; ?target could be an expr: eval only once
;;
(let ((target ?target))
(lambda (rule-trans-set)
(rule-trans-set-add rule-trans-set
target
(list tmp1 ...)
(make-is-out-of-date? target tmp1 ...)
(lambda ?args (?thunk))))))
;;
;; recursively construct temporary, hygienic variables
;;
((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
((is-out-of-date? ?target ?prereqs ?thunk) (rule ?target ?prereqs ?thunk))))
(define-syntax rule
(syntax-rules ()
((rule ?target (?prereq0 ...) ?thunk)
(rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
(define-syntax rule-tmpvars
(syntax-rules ()
((rule-tmpvars (tmp1 ...) ?target () ?thunk)
(let ((target ?target)
(prereqs (list tmp1 ...)))
(lambda (rule-candidates)
(cons (list target
prereqs
(make-is-out-of-date? target tmp1 ...)
(make-rule-build-func target prereqs ?thunk))
rule-candidates))))
((rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
(rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
(define-syntax makefile-rule-md5
;;;
;;; <md5-clause>
;;;
;;; to achieve consistency only rule-md5 will use the rule-md5-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax md5
(syntax-rules ()
((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk)
(makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk))))
((md5 ?target ?prereqs ?thunk) (rule-md5 ?target ?prereqs ?thunk))))
(define-syntax makefile-rule-md5-tmpvars
(define-syntax rule-md5
(syntax-rules ()
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk)
;;
;; ?target could be an expr: eval only once
;;
(let ((target ?target))
(lambda (rule-trans-set)
(rule-trans-set-add rule-trans-set
target
(list tmp1 ...)
(make-has-md5-digest=? ?fingerprint
target
tmp1 ...)
(lambda ?args (?thunk))))))
;;
;; recursively construct temporary, hygienic variables
;;
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target
(?prereq0 ?prereq1 ...) ?thunk)
((rule-md5 ?target (?prereq0 ...) ?thunk)
(rule-md5-tmpvars () ?target (?prereq0 ...) ?thunk))))
(define-syntax rule-md5-tmpvars
(syntax-rules ()
((rule-md5-tmpvars (tmp1 ...) ?target () ?thunk)
(let ((target ?target)
(prereqs (list tmp1 ...)))
(lambda (rule-candidates)
(cons (list target
prereqs
(make-md5-sum-changed? target tmp1 ...)
(make-md5-build-func target prereqs ?thunk))
rule-candidates))))
((rule-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(makefile-rule-md5-tmpvars (tmp1 ... tmp2) ?fingerprint
?target (?prereq1 ...) ?thunk)))))
(rule-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
(define-syntax make-is-out-of-date?
(syntax-rules ()
((make-is-out-of-date? ?target)
(lambda ?args
(cons (file-not-exists? ?target) ?args)))
((make-is-out-of-date? ?target ?prereq0 ...)
(lambda ?args
(cons (and (file-exists? ?prereq0) ...
(or (file-not-exists? ?target)
(> (file-last-mod ?prereq0)
(file-last-mod ?target)))
...)
(last ?args))))))
;;;
;;; <always-clause>
;;;
;;; to achieve consistency only rule-always will use the rule-always-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax phony
(syntax-rules ()
((phony ?target ?prereqs ?thunk) (rule-always ?target ?prereqs ?thunk))))
(define-syntax make-is-out-of-date!
(syntax-rules ()
((make-is-out-of-date? ?target ?prereq0 ...)
(lambda ?args
(cons #t (last ?args))))))
(define-syntax always
(syntax-rules ()
((always ?target ?prereqs ?thunk) (rule-always ?target ?prereqs ?thunk))))
(define-syntax make-has-md5-digest=?
(syntax-rules ()
((make-has-md5-digest=? ?fingerprint ?target)
(lambda ?args
(cons (or (file-not-exists? ?target)
(=? (md5-digest-for-port (open-input-file ?target))
?fingerprint))
?args)))
((make-has-md5-digest=? ?fingerprint ?target ?prereq0 ...)
(lambda ?args
(cons (or (file-not-exists? ?target)
(=? (md5-digest->number (md5-digest-for-port
(open-input-file ?target)))
(md5-digest->number ?fingerprint)))
(last ?args))))))
(define-syntax is-out-of-date!
(syntax-rules ()
((is-out-of-date! ?target ?prereqs ?thunk)
(rule-always ?target ?prereqs ?thunk))))
(define-syntax rule-always
(syntax-rules ()
((rule-always ?target (?prereq0 ...) ?thunk)
(rule-always-tmpvars () ?target (?prereq0 ...) ?thunk))))
(define-syntax rule-always-tmpvars
(syntax-rules ()
((rule-always-tmpvars (tmp1 ...) ?target () ?thunk)
(let ((target ?target)
(prereqs (list tmp1 ...)))
(lambda (rule-candidates)
(cons (list target
prereqs
(make-is-out-of-date! target tmp1 ...)
(make-always-build-func target prereqs ?thunk))
rule-candidates))))
((rule-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(rule-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
;;;
;;; <once-clause>
;;;
;;; to achieve consistency only rule-once will use the rule-once-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax once
(syntax-rules ()
((once ?target ?prereqs ?thunk)
(rule-once ?target ?prereqs ?thunk))))
(define-syntax rule-once
(syntax-rules ()
((rule-once ?target (?prereq0 ...) ?thunk)
(rule-once-tmpvars () ?target (?prereq0 ...) ?thunk))))
(define-syntax rule-once-tmpvars
(syntax-rules ()
((rule-once-tmpvars (tmp1 ...) ?target () ?thunk)
(let ((target ?target)
(prereqs (list tmp1 ...)))
(lambda (rule-candidates)
(cons (list target
prereqs
(make-once target tmp1 ...)
(make-once-build-func target prereqs ?thunk))
rule-candidates))))
((rule-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(rule-once-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))

14
make-rule.scm
View File

@ -28,7 +28,7 @@
(define-record-type :rule-set
(make-rule-set rules)
is-rule-set?
(rules rule-set-rules))
(rules rule-set-rules))
(define (make-empty-rule-set)
(make-rule-set '()))
@ -40,10 +40,12 @@
(error "make-rule: rule already exists."))))
(define (rule-set-get-listen-ch rule rule-set)
(let ((?thing (assq rule (rule-set-rules rule-set))))
(if (and ?thing (pair? ?thing) (is-collect&reply-channel? (cdr ?thing)))
(cdr ?thing)
(error "Rule not found in rule-set."))))
(let ((maybe-rule (assoc rule (rule-set-rules rule-set))))
(if (and maybe-rule
(pair? maybe-rule)
(is-collect&reply-channel? (cdr maybe-rule)))
(cdr maybe-rule)
(error "rule not found in rule-set."))))
;;;
;;; RULE-RESULT
@ -54,7 +56,7 @@
;;; (rule-result-build-func rule-result) --->
;;; (build-func-result . end-state) oder #f
;;;
;;; (rule-make rule init-state rule-set) ---> rule-result
;;; (rule-make rule init-state rule-set) ---> rule-result
;;;
(define-record-type :rule-result
(make-rule-result wants-build?-result build-func-result)

9
make.scm Normal file
View File

@ -0,0 +1,9 @@
(define (make rcs targets . maybe-arg)
(let-optionals maybe-arg ((init-state (list)))
(let* ((rules (rcs->rules rcs))
(rule-set (rules->rule-set rules))
(target-rules (map (lambda (t) (lookup-rule t rules))
targets)))
(map rule-make
target-rules (circular-list init-state)
(circular-list rule-set)))))

9
misc.scm Normal file
View File

@ -0,0 +1,9 @@
(define (insert pred item ls)
(if (or (null? ls) (pred item (car ls)))
(cons item ls)
(cons (car ls) (insert pred item (cdr ls)))))
(define (sort pred todo done)
(if (null? todo)
done
(sort pred (cdr todo) (insert pred (car todo) done))))

110
packages.scm
View File

@ -136,6 +136,8 @@
is-rule-set?
make-rule-result
is-rule-result?
rule-result-wants-build?
rule-result-build-func
rule-make))
(define-structure make-rule make-rule-interface
@ -159,6 +161,8 @@
is-rule-set?
make-rule-result
is-rule-result?
rule-result-wants-build?
rule-result-build-func
rule-make))
(define-structure make-rule-no-cml make-rule-no-cml-interface
@ -169,35 +173,91 @@
srfi-9)
(files make-rule-no-cml))
(define-interface rule-trans-set-interface
(export make-rule-trans-set
is-rule-trans-set?
make-empty-rule-trans-set
make-rule-trans-set
rule-trans-set-rule-candidates
rule-trans-set-known-rules
rule-trans-set-rule-set
rule-trans-set-add
rule-candidate-get
known-rules-get))
(define-structure rule-trans-set rule-trans-set-interface
(open scheme-with-scsh
srfi-1
srfi-9
make-rule)
(files rule-trans-set))
(define-interface macros-interface
(export (make :syntax)
(makefile :syntax)
(export (makefile :syntax)
(rule :syntax)
(makefile-rule :syntax)
(make-is-out-of-date? :syntax)))
(is-out-of-date? :syntax)
(md5 :syntax)
(rule-md5 :syntax)
(phony :syntax)
(always :syntax)
(is-out-of-date! :syntax)
(once :syntax)
(rule-once :syntax)))
(define-structure macros macros-interface
(open scheme-with-scsh
srfi-1
make-rule
rule-trans-set)
to-rule-set
dfs
templates
make-rule)
(files macros))
(define-interface to-rule-set-interface
(export lookup-rc
lookup-fname
lookup-rule
rcs->dag
dag->rcs
rcs->rules
rules->rule-set))
(define-structure to-rule-set to-rule-set-interface
(open scheme-with-scsh
srfi-1
templates
make-rule
dfs)
(files to-rule-set))
(define-interface dfs-interface
(export make-dfs
dfs->list
dfs-dag-show
dfs))
(define-structure dfs dfs-interface
(open scheme-with-scsh
finite-types
threads
srfi-1
srfi-9
misc
let-opt
(with-prefix rendezvous-channels cml-sync-ch/))
(files dfs))
(define-interface misc-interface
(export sort
insert))
(define-structure misc misc-interface
(open scheme-with-scsh)
(files misc))
(define-interface templates-interface
(export make-rule-build-func
make-md5-build-func
make-always-build-func
make-once-build-func
make-is-out-of-date!
make-once
make-is-out-of-date?
make-md5-sum-changed?))
(define-structure templates templates-interface
(open scheme-with-scsh
srfi-1
srfi-13)
(files templates))
(define-structure make (export make)
(open scheme-with-scsh
srfi-1
macros
let-opt
to-rule-set
make-rule)
(files make))

124
rule-trans-set.scm
View File

@ -1,124 +0,0 @@
;;; TODO:
;;;
;;; change to topological sort
;;;
;;; RULE-TRANS-SET
;;;
;;; (make-empty-rule-trans-set) ---> rule-trans-set
;;;
;;; (make-rule-trans-set rule-candidates known-rules rule-set)
;;;
;;; (rule-trans-set-rule-candidates rts) ---> (rule-candidate0 ...)
;;; (rule-trans-set-known-rules rts) ---> (known-rule0 ...)
;;; (rule-trans-set-rule-set rts) ---> rule-set
;;;
;;; (rule-trans-set-add! rule-trans-set target prereqs wants-build? build-func)
;;; ---> rule-trans-set
;;;
(define-record-type :rule-trans-set
(make-rule-trans-set rule-candidates known-rules rule-set)
is-rule-trans-set?
(rule-candidates rule-trans-set-rule-candidates)
(known-rules rule-trans-set-known-rules)
(rule-set rule-trans-set-rule-set))
(define (make-empty-rule-trans-set)
(let ((rule-candidates '())
(known-rules (alist-cons '() '() '()))
(rule-set (make-empty-rule-set)))
(make-rule-trans-set rule-candidates known-rules rule-set)))
;;; o every incoming rule is considered as a rule-candidate
;;; o add the new rule-candidate to rule-candidates
;;; o run known-rules-update afterwards
(define rule-trans-set-add
(lambda (rule-trans-set target prereqs wants-build? build-func)
(rule-candidate-add rule-trans-set target prereqs wants-build? build-func)))
(define rule-candidate-add
(lambda (rule-trans-set target prereqs wants-build? build-func)
(let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set))
(rule-args (list prereqs wants-build? build-func)))
(make-rule-trans-set (alist-cons target rule-args rule-candidates)
known-rules
rule-set))))
(define (rule-candidate-del rule-trans-set target)
(let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set)))
(make-rule-trans-set (alist-delete! target rule-candidates)
known-rules
rule-set)))
(define (rule-candidate-get rule-trans-set target)
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(maybe-rule-candidate (assq target rule-candidates)))
(if maybe-rule-candidate
(cons target (cdr (assq target rule-candidates)))
maybe-rule-candidate)))
;;; o if a target's prereqs are all in known-rules then the rule-candidate
;;; can be added to the known-rules as a freshly created rule
;;; o any rule-candidate with () as prereqs can be added to the known-rules
;;; as well, so this will be the first element of the known-rules
(define known-rules-add
(lambda (rule-trans-set target prereqs wants-build? build-func)
(let ((rule (make-rule (map (lambda (prereq)
(known-rules-get rule-trans-set prereq))
prereqs)
wants-build?
build-func))
(rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set)))
(make-rule-trans-set rule-candidates
(alist-cons target rule known-rules)
(rule-set-add rule rule-set)))))
(define (known-rules-get rule-trans-set target)
(let* ((known-rules (rule-trans-set-known-rules rule-trans-set))
(maybe-rule (assoc target known-rules)))
(if maybe-rule (cdr maybe-rule) maybe-rule)))
(define (known-rules-update rts)
(let until-no-change ((last-rcs (length (rule-trans-set-rule-candidates rts)))
(rule-trans-set rts))
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(candidate-descs (map cons (map car rule-candidates)
(map cdr rule-candidates))))
(let for-candidates ((current-candidate-desc (car candidate-descs))
(to-do-candidate-desc (cdr candidate-descs))
(current-rts rule-trans-set))
(let ((target (list-ref current-candidate-desc 0))
(prereqs (list-ref current-candidate-desc 1))
(wants-build? (list-ref current-candidate-desc 2))
(build-func (list-ref current-candidate-desc 3)))
(let* ((known-rules (rule-trans-set-known-rules current-rts))
;;
;; if all prereqs of a target are in known-rules
;; then the rule-candidate can be added to the known-rules
;; after its deletion of the rule-candidates
;;
(new-rts (if (not (memq #f
(map (lambda (prereq)
(assoc prereq known-rules))
prereqs)))
(known-rules-add (rule-candidate-del
current-rts
target)
target prereqs
wants-build? build-func)
current-rts)))
(if (not (null? to-do-candidate-desc))
(for-candidates (car to-do-candidate-desc)
(cdr to-do-candidate-desc)
new-rts)
(let ((current-rcs (length (rule-trans-set-rule-candidates
new-rts))))
(if (or (= current-rcs last-rcs) (= current-rcs 0))
new-rts
(until-no-change current-rcs new-rts))))))))))

209
templates.scm Normal file
View File

@ -0,0 +1,209 @@
;;; TODO:
;;;
;;; (update-md-sum ...) is (due to history) not very lucky
;;;
(define digest-files (list "checksums.md5"
"fingerprints.md5"
"digests.md5"))
(define digest-extensions (list ".md5" ".fp" ".digest"))
(define (make-rule-build-func target prereqs thunk)
(lambda args
(cons (begin
(display ";;; rule : ")
(display target)
(newline)
(thunk))
(last args))))
(define (make-md5-build-func target prereqs thunk)
(lambda args
(cons (begin
(display ";;; md5 : ")
(display target)
(newline)
(thunk))
(last args))))
(define (make-always-build-func target prereqs thunk)
(lambda args
(cons (begin
(display ";;; always : ")
(display target)
(newline)
(thunk))
(last args))))
(define (make-once-build-func target prereqs thunk)
(lambda args
(cons (begin
(display ";;; once : ")
(display target)
(newline)
(thunk))
(last args))))
(define (make-is-out-of-date! target . prereqs)
;; init-state is the last arg
;; pass it untouched to the result
(lambda args (cons #t (last args))))
(define (make-once target . prereqs)
;; init-state is the last arg
;; pass it untouched to the result
(lambda args (cons (file-not-exists? target) (last args))))
(define (make-is-out-of-date? target . prereqs)
(lambda args
(let ((init-state (last args)))
(cons (or (file-not-exists? target)
(and (not (null? prereqs))
(let for-each-prereq ((prereq (car prereqs))
(todo (cdr prereqs)))
(and (file-exists? prereq)
(> (file-last-mod prereq)
(file-last-mod target))
(or (null? todo)
(for-each-prereq (car todo) (cdr todo)))))))
init-state))))
(define (make-md5-sum-changed? target . prereqs)
(lambda args
(let ((init-state (last args))
(tfname (expand-file-name target (cwd))))
(cons (or (file-not-exists? tfname)
(or (null? prereqs)
(let for-each-prereq ((prereq (car prereqs))
(todo (cdr prereqs)))
(let ((pname (expand-file-name prereq (cwd))))
(or (and (file-exists? pname)
(> (file-last-mod pname)
(file-last-mod tfname))
(checksum-changed? pname)
(or (md5-sum-update pname) #t))
(and (not (null? todo))
(for-each-prereq (car todo) (cdr todo))))))))
init-state))))
(define (check-files-target+extensions target checksum)
(map (lambda (digest-file)
(lambda ()
(let ((dfile (expand-file-name digest-file (cwd))))
(or (file-not-exists? dfile)
(let ((strls (port->string-list (open-input-file dfile))))
(= checksum
(string->number (if (null? strls) "" (car strls)))))))))
(map (lambda (ext)
(string-append target ext))
digest-extensions)))
(define (update-files-target+extensions target checksum)
(map (lambda (digest-file)
(lambda ()
(let ((dfile (expand-file-name digest-file (cwd))))
(and (file-exists? dfile)
(let ((outport (open-output-file dfile)))
(display ";;; update : ") (display target) (newline)
(with-current-output-port
outport
(lambda ()
(display (number->string checksum)) (newline)))
(close outport)
#t)))))
(map (lambda (ext)
(string-append target ext))
digest-extensions)))
(define (digest-file->string-list digest-fname)
(let* ((inport (open-input-file (expand-file-name digest-fname (cwd))))
(strls (map (lambda (str)
(let ((ls (string-tokenize str)))
(if (not (null? ls))
(let ((fp (car ls))
(name (cadr ls)))
(cons name fp))
'())))
(port->string-list inport))))
(close inport)
strls))
(define (check-digest-files target checksum)
(map (lambda (digest-file)
(lambda ()
(let ((dfile (expand-file-name digest-file (cwd)))
(tname (file-name-nondirectory target)))
(or (file-not-exists? dfile)
(let* ((*fname-md5* (digest-file->string-list dfile))
(maybe-md5 (if (or (null? *fname-md5*)
(null? (car *fname-md5*)))
#f
(assoc tname *fname-md5*))))
(or (not maybe-md5)
(= checksum
(string->number (cdr maybe-md5)))))))))
digest-files))
(define (string-list->digest-file dfname strls)
(let ((outport (open-output-file (expand-file-name dfname (cwd))))
(names (if (or (null? strls) (null? (car strls))) '() (map car strls)))
(sums (if (or (null? strls) (null? (car strls))) '() (map cdr strls))))
(display ";;; update : ") (display dfname) (newline)
(for-each (lambda (name fp)
(with-current-output-port outport
(for-each display (list fp " " name))
(newline)))
names sums)
(close outport)
#t))
(define (update-digest-files target checksum)
(map (lambda (digest-file)
(lambda ()
(let ((dfile (expand-file-name digest-file (cwd)))
(tname (file-name-nondirectory target)))
(and (file-exists? dfile)
(let* ((*fname-md5* (digest-file->string-list dfile))
(cleaned-table (if (or (null? *fname-md5*)
(null? (car *fname-md5*)))
(list)
(alist-delete tname *fname-md5*))))
(string-list->digest-file
dfile
(alist-cons tname checksum cleaned-table)))))))
digest-files))
(define (checksum-changed? target)
(let* ((inport (open-input-file target))
(checksum (md5-digest->number (md5-digest-for-port inport)))
(result-funcs (append (check-files-target+extensions target checksum)
(check-digest-files target checksum))))
(close inport)
(not (let each-result-and ((current (car result-funcs))
(todo (cdr result-funcs)))
(let ((res (current)))
(and res
(or (null? todo)
(each-result-and (car todo) (cdr todo)))))))))
(define (md5-sum-update target)
(let* ((tname (expand-file-name target (cwd)))
(inport (open-input-file tname))
(checksum (md5-digest->number (md5-digest-for-port inport)))
(update-funcs (append (update-files-target+extensions target checksum)
(update-digest-files target checksum))))
(close inport)
(let ((update-ok? (lambda ()
(let each-update-and ((current (car update-funcs))
(todo (cdr update-funcs)))
(or (current)
(and (not (null? todo))
(each-update-and (car todo) (cdr todo))))))))
;; the default is to use the filename with .md5 extension
(if (not (update-ok?))
(let ((outport (open-output-file (string-append tname ".md5"))))
(with-current-output-port outport
(begin
(display checksum)
(newline)))
(close outport))))))

135
to-rule-set.scm
View File

@ -1,45 +1,122 @@
(define (rcs->dag rcs)
(map (lambda (rc)
(make-dfs (car rc) (cadr rc) (caddr rc) (cadddr rc)))
(let ((target (list-ref rc 0))
(prereqs (list-ref rc 1))
(wants-build? (list-ref rc 2))
(build-func (list-ref rc 3)))
(make-dfs target prereqs (list wants-build? build-func))))
rcs))
;;;
;;; if dfs inserted leafs they have the ignored-data set to #f
;;; the build-func will then be set to produce an error
;;; in case of the file doesn't exist
;;;
(define (dag->rcs dag)
(map (lambda (node)
(let* ((ls (dfs->list node))
(target (car ls))
(prereqs (cadr ls))
(wants-build? (caddr ls))
(build-func (cdddr ls)))
(list target prereqs wants-build? build-func)))
(target (list-ref ls 0))
(prereqs (list-ref ls 1))
(ignored (list-ref ls 2)))
(if ignored
(let ((wants-build? (car ignored))
(build-func (cadr ignored)))
(list target prereqs wants-build? build-func))
(let* ((tfname (expand-file-name target (cwd)))
(wants-build? (lambda args
(cons (file-not-exists? tfname)
(last args))))
(build-func (lambda args
(error "file (assumed leaf) does not exist:"
tfname))))
(list target prereqs wants-build? build-func)))))
dag))
(define (lookup-rc rcs rc)
(define (lookup-rc rc rcs)
(let ((maybe-rc (find (lambda (current)
(eq? (car rc) (car current)))
rcs)))
(if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
(define (rcs->rules rcs)
(let ((sorted-rcs (dag->rcs (dfs (rcs->dag rcs)))))
(map (lambda (rc)
(let* ((target (car rc))
(prereqs (cadr rc))
(wants-build? (caddr rc))
(build-func (cdddr rc))
(prereq-rcs (map (lambda (p)
(lookup-rc sorted-rcs p))
prereqs))
(rule (make-rule prereq-rcs wants-build? build-func)))
(cons target rule)))
rcs)))
(define (lookup-fname fname rcs)
(let ((maybe-fname (find (lambda (current)
(eq? fname (car current)))
rcs)))
(if maybe-fname maybe-fname (error "lookup-fname: fname not found."))))
(define (rules->rule-set rules)
(let for-each-rule ((current-rule (if (null? rules) '() (car rules)))
(rules-to-do (if (null? rules) '() (cdr rules)))
(rule-set (make-empty-rule-set)))
(if (not (null? rules-to-do))
(for-each-rule (car rules-to-do)
(cdr rules-to-do)
(rule-set-add current-rule rule-set)))
rule-set))
(define (lookup-rule fname rules)
(let ((maybe-rule (assoc fname rules)))
(if maybe-rule
(cdr maybe-rule)
(error "lookup-rule: fname not found in rules."))))
(define (rcs->rules rule-candidates)
(let* ((sorted-dag (dfs (rcs->dag rule-candidates)))
(sorted-rcs (dag->rcs sorted-dag)))
;; (dfs-dag-show sorted-dag (car sorted-dag))
;; (rcs-show sorted-rcs)
(if (not (null? sorted-rcs))
(let for-all-rcs ((rc (car sorted-rcs))
(todo (cdr sorted-rcs))
(last-done '()))
(let* ((target (list-ref rc 0))
(prereqs (list-ref rc 1))
(wants-build? (list-ref rc 2))
(build-func (list-ref rc 3))
(done (cons (cons target
(make-rule (map (lambda (p)
(lookup-rule p last-done))
prereqs)
wants-build?
build-func))
last-done)))
(if (not (null? todo))
(for-all-rcs (car todo) (cdr todo) done)
done))))))
(define (rules->rule-set rule-alist)
(if (not (null? rule-alist))
(let ((rules (map cdr rule-alist)))
(let for-each-rule ((current-rule (car rules))
(rules-to-do (cdr rules))
(rule-set (make-empty-rule-set)))
(let ((next-rule-set (rule-set-add current-rule rule-set)))
(if (not (null? rules-to-do))
(for-each-rule (car rules-to-do)
(cdr rules-to-do)
next-rule-set)
next-rule-set))))))
(define (rcs-show rcs)
(newline) (newline) (newline) (newline)
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
(display ";;; rcs-show ;;;\n")
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
(let ((rc-show (lambda (rc)
(let ((target (list-ref rc 0))
(prereqs (list-ref rc 1))
(wants-build? (list-ref rc 2))
(build-func (list-ref rc 3)))
(newline)
(display "; target: ")
(display target)
(newline)
(display "; prereqs: ")
(display prereqs)
(newline)
(display "; wants-build?: ")
(display wants-build?)
(newline)
(display "; build-func: ")
(display build-func)
(newline)))))
(if (not (null? rcs))
(let visit-each-rc ((current-rc (car rcs))
(todo-rcs (cdr rcs)))
(rc-show current-rc)
(if (not (null? todo-rcs))
(visit-each-rc (car todo-rcs) (cdr todo-rcs))
(begin
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
(newline) (newline) (newline) (newline)))))))