Commit ade1ed76 authored by Erick Gallesio's avatar Erick Gallesio

Fixed a problem with macros with great areity (> 12)

parent 777373c3
;;;;
;;;; boot.stk -- Default boot file
;;;;
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 01-Jan-2000 15:04 (eg)
;;;; Last file update: 21-Dec-2006 23:51 (eg)
;;;; Last file update: 1-Feb-2007 18:57 (eg)
;;;;
(include "runtime.stk") ; Definition necessary for the bootstrap
......@@ -53,7 +53,7 @@
(autoload "pp" pp pretty-print)
(autoload "env" null-environment scheme-report-environment
interaction-environment)
(syntax-autoload "snow-support" package*)
;(syntax-autoload "snow-support" package*)
(autoload "srfi-27" random-integer random-real)
(syntax-autoload "srfi-34" with-exception-handler guard)
(syntax-autoload "srfi-35" define-condition-type condition)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 25-Jan-2007 22:22 (eg)
;;;; Last file update: 3-Feb-2007 16:01 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -349,7 +349,7 @@ doc>
(proc (caddr l))
(expander `(lambda (form e) (apply ,proc (cdr form)))))
;; Install expander for further compilation
(install-expander! name (eval expander) proc)))))
(install-expander! name (eval expander) #f)))))
;;;;
......@@ -1419,7 +1419,6 @@ doc>
(let* ((name (car x))
(proc (cdr x))
(expander `(lambda (form e) (apply ,proc (cdr form)))))
(eprintf "DEBUG: create back macro ~S\n" name)
(install-expander! name (eval expander) proc)))
(key-get infos :expanders '()))
)))
......
;;;;
;;;; peephole.stk -- Peephole Optimiser fro the STklos VM
;;;;
;;;; Copyright 2001-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2001-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 20:32 (eg)
;;;; Last file update: 27-Sep-2006 13:41 (eg)
;;;; Last file update: 3-Feb-2007 15:18 (eg)
;;;;
; ======================================================================
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Mar-2001 22:49 (eg)
;;;; Last file update: 25-Jan-2007 21:23 (eg)
;;;; Last file update: 1-Feb-2007 22:39 (eg)
;;;;
......@@ -67,8 +67,9 @@
(define (install-expander! id proc code)
(set! *expander-list* (cons (cons id proc) *expander-list*))
;; Keep the code associated to the macro to save it in byte-code header
(set! *expander-list-src* (cons (cons id code) *expander-list-src*)))
(when code
;; Global macro: Keep the macro code to save it in byte-code header
(set! *expander-list-src* (cons (cons id code) *expander-list-src*))))
;;;
;;; Expander-list-src management
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Jan-2007 16:59 (eg)
;;;; Last file update: 1-Feb-2007 11:00 (eg)
;;;; Last file update: 1-Feb-2007 15:55 (eg)
;;;;
......@@ -76,6 +76,27 @@
(else
(die (format "bad package* clause ~S" pkg*)))))))
;; ----------------------------------------------------------------------
;; local-snowfort-add-tuning! ...
;; ----------------------------------------------------------------------
(define (local-snowfort-add-tuning! snowball package version tuning directory)
(unless (equal? tuning "stklos")
(die "Cannot manage non STklos tunings"))
(when (> (snowman-verbosity) 0)
(eprintf "Adding tuning for package ~S (~a) to local repository\n"
package version))
(let* ((cache-name (make-path (snowman-cache-directory) (basename snowball)))
(descr `(,package
,version
:tuning-only #t
:tunings (("stklos"
:url ""
:snowball ,cache-name
:md5 ,(md5sum-file snowball))))))
(copy-file snowball cache-name)
(add-description-to-local-repository! descr)))
;; ----------------------------------------------------------------------
;; build-package-description ...
;; ----------------------------------------------------------------------
......@@ -109,14 +130,4 @@
:tunings ()
:dependencies ,(build-dependencies lst))))
;; ----------------------------------------------------------------------
;; local-snowfort-add-tuning! ...
;; ----------------------------------------------------------------------
(define (local-snowfort-add-tuning! snowball package version tuning directory)
(unless (equal? tuning "stklos")
(die "Cannot manage non STklos tunings"))
(when (> (snowman-verbosity) 0)
(eprintf "Adding tuning for package ~S (~a) to local repository\n"
package version)))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 31-Jan-2007 14:48 (eg)
;;;; Last file update: 1-Feb-2007 17:54 (eg)
;;;;
(define interesting-tuning "stklos") ; The tuning we want to keep in our base
......@@ -274,26 +274,34 @@
(define (add-description-to-local-repository! descr)
(define (insert-descr lst name version descr)
(let Loop ((lst lst)
(res '()))
(cond
((null? lst)
(cons descr res))
((and (equal? (caar lst) name)
(equal? (cadar lst) version))
(Loop (cdr lst) res))
(else
(Loop (cdr lst) (cons (car lst) res))))))
(let* ((repo (make-path (snowman-snowforts-directory) "local"))
(old (with-input-from-file repo read))
(name (car descr))
(vers (cadr descr))
(new (insert-descr old name vers descr)))
;; save the new version
(with-output-to-file repo
(lambda ()
(pp new :port #t)))))
(let ((descr-tuning-only (key-get (cddr descr) :tuning-only #f)))
(let Loop ((lst lst)
(res '()))
(cond
((null? lst)
(cons descr res))
((and (equal? (caar lst) name)
(equal? (cadar lst) version))
(let ((lst-tuning-only (key-get (cddar lst) :tuning-only #f)))
(cond
((equal? descr-tuning-only lst-tuning-only)
;; We replace a tuning/package by another
(Loop (cdr lst) res))
(else
;; One is a package the other is a tuning
(Loop (cdr lst) (cons (car lst) res))))))
(else
(Loop (cdr lst) (cons (car lst) res)))))))
(let* ((repo (make-path (snowman-snowforts-directory) "local"))
(old (with-input-from-file repo read))
(name (car descr))
(vers (cadr descr))
(new (insert-descr old name vers descr)))
;; save the new version
(with-output-to-file repo
(lambda ()
(pp new :port #t)))))
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
/*
* mutex.c -- Pthread Mutexes in Scheme
*
* Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 28-Oct-2006 16:18 (eg)
* Last file update: 1-Feb-2007 17:20 (eg)
*/
#include <lurc.h>
......@@ -383,7 +383,7 @@ DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))
return STk_void;
}
DEFINE_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv))
DEFINE_PRIMITIVE("condition-variable-broadcast!", condv_broadcast, subr1, (SCM cv))
{
int err;
if (! CONDVP(cv)) STk_error_bad_condv(cv);
......
/*
* mutex-none.c -- Pthread Mutexes in Scheme
*
* Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 16-Apr-2006 11:13 (eg)
* Last file update: 16-Apr-2006 11:39 (eg)
* Last file update: 1-Feb-2007 17:20 (eg)
*/
......@@ -48,6 +48,6 @@ int STk_init_mutexes(void)
FAKE_PRIMITIVE("condition-variable-specific");
FAKE_PRIMITIVE("condition-variable-specific-set!");
FAKE_PRIMITIVE("condition-variable-signal!");
FAKE_PRIMITIVE("condition-variable-brodcast!");
FAKE_PRIMITIVE("condition-variable-broadcast!");
return TRUE;
}
/*
* mutex-pthreads.c -- Pthread Mutexes in Scheme
*
* Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* Copyright 2006-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 25-Oct-2006 16:22 (eg)
* Last file update: 1-Feb-2007 17:20 (eg)
*/
#include <unistd.h>
......@@ -290,7 +290,7 @@ DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))
* |Condition-variable-broadcast!| returns an unspecified value.
doc>
*/
DEFINE_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv))
DEFINE_PRIMITIVE("condition-variable-broadcast!", condv_broadcast, subr1, (SCM cv))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
pthread_cond_broadcast(&CONDV_MYCONDV(cv));
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 26-Jan-2007 11:35 (eg)
* Last file update: 3-Feb-2007 19:19 (eg)
*/
// INLINER values
......@@ -774,6 +774,28 @@ DEFINE_PRIMITIVE("%vm", set_vm_debug, vsubr, (int argc, SCM *argv))
patch_environment(STk_get_current_vm());
return STk_void;
}
//#define VM_OFFSET(x) ((SCM) x - (SCM) vm->sp)
//
//static void show_stack_content(void)
//{
// int i = 0;
// vm_thread_t *vm = STk_get_current_vm();
// char buff[10];
//
// /* Show the registers */
// STk_debug("=====================");
// STk_debug("FP = %d", VM_OFFSET(vm->fp));
// for (i=0; ;i++) {
// STk_debug("offset %d value %d (0x%x)", i, vm->sp[i], vm->sp[i]);
// fgets(buff, 10, stdin);
// switch(*buff) {
// case 's': STk_debug("Scheme value ~S", vm->sp[i]); break;
// case 'q': return;
// default: /* nothing */;
// }
// }
//}
#endif
......@@ -1393,7 +1415,7 @@ FUNCALL: /* (int nargs, int tailp) */
SCM *old_fp = (SCM *) ACT_SAVE_FP(vm->fp);
/* Move the arguments of the function to the old_fp */
if (nargs) memcpy(old_fp-nargs, vm->sp, nargs*sizeof(SCM));
if (nargs) memmove(old_fp-nargs, vm->sp, nargs*sizeof(SCM));
vm->fp = old_fp;
/* Push a new environment on the stack */
......
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