Commit 0487a952 authored by Erick Gallesio's avatar Erick Gallesio

bigloo rewritting for ScmPkg

parent b341be4e
......@@ -21,18 +21,21 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 7-Feb-2007 13:39 (eg)
;;;; Last file update: 21-Mar-2007 14:28 (eg)
;;;; Last file update: 23-Mar-2007 08:43 (eg)
;;;;
(define *scmpkg-languages*
'(
;; STklos
(stklos :suffix "stk")
;; Bigloo
(bigloo :suffix "scm")
;; Snow
(snow :suffix "scm")
;; Gambit
(gambit :suffix "scm")
;; ScmPkg
(scmpkg :suffix "scm")
;; R5RS (the default)
(r5rs :suffix "scm")))
(r5rs :suffix "scm")
;; Snow
(snow :suffix "scm")
;; STklos
(stklos :suffix "stk")
))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Manuel Serrano
;;;; Creation date: 16-Mar-2007 15:59 (eg)
;;;; Last file update: 19-Mar-2007 14:40 (eg)
;;;; Last file update: 22-Mar-2007 17:23 (eg)
;;;;
(require "pp")
......@@ -43,7 +43,7 @@
(define (error-notify e)
(pp e))
(define (test name prgm res)
(define (test name prgm res equal)
(printf "~a ... " name)
(flush-output-port (current-output-port))
(let ((provided (with-handler
......@@ -54,9 +54,8 @@
(error-notify e)
e)))
(prgm))))
(if (or (eq? res '__unspecified__)
(and (procedure? res) (res provided))
(equal? res provided))
(if (or (and (procedure? res) (res provided))
(equal res provided))
(begin
(set! success (+ 1 success))
(display "ok.\n"))
......@@ -94,6 +93,7 @@
) ;;; *** End of module recette ***
;; ----------------------------------------------------------------------
;; define-test ...
;; ----------------------------------------------------------------------
......@@ -103,19 +103,34 @@
(define-macro (define-test id prgm . rest)
(let ((t (cond
((null? rest)
`(list ',id (lambda () ,prgm) '__unspecified__))
((and (pair? rest)
(eq? (car rest) :result)
(pair? (cdr rest))
(null? (cddr rest)))
`(list ',id (lambda () ,prgm) ,(cadr rest)))
`(list ',id (lambda () ,prgm) #f (lambda (x y) #t)))
((and (pair? rest)
(eq? (car rest) :error)
(null? (cdr rest)))
`(list ',id (lambda () ,prgm) :error))
`(list ',id (lambda () ,prgm) :error equal?))
(else
(error 'define-test "illegal rest argument ~S" rest)))))
(let loop ((rest rest)
(result #f)
(comp 'equal?))
(cond
((null? rest)
`(list ',id (lambda () ,prgm) ,result ,comp))
((null? (cdr rest))
(error 'define-test "Illegal argument" rest))
(else
(case (car rest)
((:result)
(loop (cddr rest)
(cadr rest)
comp))
((:equal)
(loop (cddr rest)
result
(cadr rest)))
(else
(error 'define-test
"Illegal rest argument"
rest))))))))))
`(recette-add-test! ,t)))
(provide "recette")
\ No newline at end of file
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Jan-2007 16:59 (eg)
;;;; Last file update: 14-Mar-2007 10:11 (eg)
;;;; Last file update: 24-Mar-2007 16:17 (eg)
;;;;
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 21-Mar-2007 13:57 (eg)
;;;; Last file update: 22-Mar-2007 11:44 (eg)
;;;; Last file update: 22-Mar-2007 17:14 (eg)
;;;;
(include "lang-bigloo.inc")
......@@ -40,10 +40,11 @@
(display token)
(loop (lexer-next-token lex))))))))
(let ((tmp (temporary-file-name)))
(do-rewrite src tmp)
(copy-file tmp src)
(remove-file tmp)))
(when (file-exists? src)
(let ((tmp (temporary-file-name)))
(do-rewrite src tmp)
(copy-file tmp src)
(remove-file tmp))))
;;;
;;; Register this language
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 22-Dec-2006 11:32 (eg)
;;;; Last file update: 21-Mar-2007 14:32 (eg)
;;;; Last file update: 24-Mar-2007 16:14 (eg)
;;;;
(require "getopt")
......@@ -72,9 +72,8 @@
(set! actions (cons 'clear-cache actions)))
(("add" :alternate "a" :arg sb
:help "Add <sb> pkgball to the local repository")
(local-description-add! sb)
(exit 0))
(set! actions (cons (list 'add sb) actions)))
"Misc"
(("directory" :arg dir :alternate "C"
:help "Change to directory <dir> when extracting")
......@@ -142,5 +141,10 @@
((package-deps)
(for-each (lambda (x) (printf "~a\n" x))
(package-deps* (cadar actions))))
((add)
(local-description-add!(cadar actions))
(exit 0))
(else (error "bad command ~S" (car actions))))
(loop (cdr actions))))))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 17:44 (eg)
;;;; Last file update: 4-Mar-2007 12:26 (eg)
;;;; Last file update: 24-Mar-2007 16:18 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -46,7 +46,7 @@
;*---------------------------------------------------------------------*/
(define (parse-pkgball-name name)
(let ((res (regexp-match "(_*[^_]+)_*([a-z]+)*-([0-9]+.[0-9]+.[0-9]+).tar.gz"
name)))
(basename name))))
(if res
(values (cadr res) (caddr res) (cadddr res))
(values #f #f #f))))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 14-Mar-2007 10:15 (eg)
;;;; Last file update: 24-Mar-2007 16:39 (eg)
;;;;
......@@ -298,8 +298,8 @@
((and (equal? (car item) type)
(equal? (cadr item) name)
(equal? (key-get (cddr item) :version "0.0.0") version))
(Loop (cdr lst)
(cons item res)))
(cons descr
(append res (cdr lst))))
(else
(Loop (cdr lst)
(cons (car lst) res))))))))
......@@ -313,4 +313,5 @@
;; save the new version
(with-output-to-file repo
(lambda ()
(display ";; Generated -*- scheme -*- file. *DO NOT EDIT*\n\n")
(pp new :port #t)))))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 20-Mar-2007 15:13 (eg)
;;;; Last file update: 22-Mar-2007 11:44 (eg)
;;;; Last file update: 22-Mar-2007 17:14 (eg)
;;;;
(define *code-rewriters* '())
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment