www

commit 1023fbd58e053cba9a74940a7a7086b389e0c641
parent 4fed13729255f18f4933d703f1a1f0b0f3ac54fd
Author: Bertrand BRUN <bertrand0brun@gmail.com>
Date:   Sun, 21 Nov 2010 20:10:19 +0100

Ajout des fonctions permettant de gere les primitives en Scheme

Diffstat:
M
scheme/meval-scheme.scm
 | 
41
+++++++++++++++++++++++++++++++++++++++--

1 file changed, 39 insertions(+), 2 deletions(-)
diff --git a/scheme/meval-scheme.scm b/scheme/meval-scheme.scm
@@ -397,4 +397,42 @@
 ;; - le second element est la fonction du Scheme sous-jacent qui implante la primitive,
 ;; - le troisieme element est un comparateur (= ou >=)
 ;; - le quatrieme element est un entier naturel, ces deux derniers elements permettant
-;; de specifier l'arite de la primitive.
-\ No newline at end of file
+;;   de specifier l'arite de la primitive.
+
+;; primitive?: Valeur -> bool
+;; (primitive? val) rend vrai ssi "val" est une fonction primitive
+(define (primitive? val)
+  (if (pair? val)
+	  (equal? (car val) '*primitive*)
+	  #f))
+
+;; primitive-creation: N-UPLET[(Valeur... -> Valeur)(num * num -> bool) num] -> Primitive
+;; (primitive-creation f-c-n) rend la primitive implantee par la fonction (du Scheme sous-jacent)
+;; "f", le premier element de "f-c-n", et dont l'arite est specifier par le
+;; comparateur "c", deuxieme element de "f-c-n" et l'entier "n", le troisieme element
+(define (primitive-creation f-c-n)
+  (cons '*primitive* f-c-n))
+
+;; primitive-invocation: Primitive * LISTE[Valeur] -> Valeur
+;; (primitive-invocation p args) rend la valeur de l'application de la primitive "p" aux element
+;; de args
+(define (primitive-invocation p args)
+  (let ((n       (length args))
+		(f       (cadr p))
+		(compare (caddr p))
+		(arite   (cadddr p)))
+	(if (compare n arite)
+		(cond
+		 ((= n 0) (f))
+		 ((= n 1) (f (car args)))
+		 ((= n 2) (f (car args) (cadr args)))
+		 ((= n 3) (f (car args) (cadr args) (caddr args)))
+		 ((= n 4) (f (car args) (cadr args) (caddr args) (cadddr args)))
+		 (else
+		  (scheme-erreur 'primitive-invocation
+						 "limite implantation (arite quelconque < 5)" args)))
+		(scheme-erreur 'primitive-invocation
+					   "arite incorrecte" args))))
+
+;;     }}} Primitives
+