;;; .EnTete "Le-Lisp (c) version 15.2" " " "Test des appels externes"
;;; .EnPied "testextern.ll" "%" " "
;;;
;;; .SuperTitre "Test des appels externes"
;;;
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
;;; .Centre "*****************************************************************"
;;;
;;; .Centre "$Header: testextern.ll,v 4.9 88/12/07 20:00:40 kuczynsk Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'testextern))
(unless (featurep 'testcomm)
(libload testcomm))
(defvar cfilc (catenate #:system:directory "lltest/testext.c"))
(defvar cfilo "/tmp/testext.o")
(when #:system:cloadp
(print "compiling " cfilc)
(if (featurep 'MC68881)
(comline (catenate "cc -f68881 -I. -c " cfilc " -o " cfilo))
(comline (catenate "cc -I. -c " cfilc " -o " cfilo)) )
(print "cloading " cfilo)
(cload cfilo)
(comline (catenate "rm -f " cfilo)))
(unless (or (featurep '64bitfloats)
(eq 0.0 0.0))
(add-feature '64bitfloats))
(defextern ←tlno () fix)
(defextern ←tlfix (fix) fix)
(defextern ←tlfloat (float) fix)
(defextern-cache t)
(defextern ←tlstring (string) fix)
(defextern ←tlvector (vector fix) fix)
(defextern ←trfix (rfix))
(defextern ←trfloat (rfloat) float)
(defextern ←ttabint (fix fixvector))
; On ne sait pas passer (& repasser) des tableaux de flottants 64 bits.
(unless (featurep '64bitfloats)
(defextern ←ttabflt (fix floatvector))
)
(defextern ←tlt (t) fix)
(defextern ←tlexternal (external) fix)
(defextern ←tcfloat (fix) float)
(defextern ←tcfloat2 (float float) float)
(defextern ←f←s←to←d () float)
(defextern ←tcstring (fix) string)
(defextern ←tct (fix) t)
(defextern ←tcexternal (fix) external)
(defextern ←tlnadic (fix fix fix fix fix fix fix fix fix fix fix) fix)
(defextern ←tnbmaxi (fix fix fix fix fix fix fix fix
fix fix fix fix fix fix fix fix
fix fix fix fix fix fix fix fix
fix fix fix fix fix fix fix fix ))
(defextern ←tnbmaxf (float float float float float float float float
float float float float float float float float
float float float float float float float float
float float float float float float float float ))
(defextern ←tnbmaxri (rfix rfix rfix rfix rfix rfix rfix rfix
rfix rfix rfix rfix rfix rfix rfix rfix
rfix rfix rfix rfix rfix rfix rfix rfix
rfix rfix rfix rfix rfix rfix rfix rfix ))
(defextern ←tnbmaxrf (rfloat rfloat rfloat rfloat rfloat rfloat rfloat rfloat
rfloat rfloat rfloat rfloat rfloat rfloat rfloat rfloat
rfloat rfloat rfloat rfloat rfloat rfloat rfloat rfloat
rfloat rfloat rfloat rfloat rfloat rfloat rfloat rfloat))
(defextern ←trfixrfloat (rfix rfloat) float)
; On ne sait pas passer (& repasser) des tableaux de flottants 64 bits.
(unless (featurep '64bitfloats)
(defextern ←ttabother (fix fix fixvector float float fix
floatvector fixvector fix fix))
)
(defextern ←struct←un (fix float string) external)
(defextern ←tltout (fix float string vector fix) fix)
(defextern ←tlmalloc (fix) external)
(defextern ←getsym (string) t)
(defextern ←cons←en←c (t t) t)
(defextern ←vect←to←list (vector fix) t)
(defextern ←fib (fix) fix)
(defextern ←init←fib ())
(defextern ←tlcfloat () t) ; test pusharg + lispcall float
; On ramene un type T car le resultat rendu, est
; un flottant qui a ete range' dans la pile lisp
; avec PUSHARG, donc de'ja` transforme' pour
; le monde Lisp. Si on mettait FLOAT, on ferait
; la transformation encore 1 fois!!
(defextern ←tlcstring () string) ; test returning a string from lisp
; Avec une string, c'est OK car C sait coercer un
; ptr en un autre pointeur.
(defextern ←tpastring () fix) ; test pusharg string
(defextern-cache ())
(de #:testgc:gcalarm () (setq gcalarm t))
(de fib (n)
(cond ((eq n 1) 1)
((eq n 2) 1)
(t (add (←fib (sub1 n)) (←fib (sub n 2))))))
(testfn ())
(test-serie "Test d'arguments du type FIX" ())
(←tlno) 0
(←tlfix 0) 0
(←tlfix 1) 2
(←tlfix -1) -2
(←tlfix 32767) -2
(←tlfix -32767) 2
(←tlfix #$8000) 0
(test-serie "Test d'arguments du type FLOAT" ())
(←tlfloat 0.) 0
(←tlfloat 1.) 2
(←tlfloat -1.) -2
(←tlfloat 32767.) -2
(←tlfloat -32767.) 2
(←tlfloat 0.001) 0
(←tlfloat 0.5) 1
(←tlfloat -0.5) -1
(test-serie "Test d'arguments du type STRING" ())
(setq a "abc") "abc"
(←tlstring a) 3
a "Cbc"
(←tlstring "") 0
(test-serie "Test d'arguments du type VECTOR" ())
(setq a #[1 a b 4]) #[1 a b 4]
(←tlvector a (vlength a)) 1
a #[1 a a 4]
(setq a #[-1 -2]) #[-1 -2]
(←tlvector a (vlength a)) -1
a #[-1 -2]
(test-serie "Test d'arguments du type RFIX" ())
(←trfix 3) 6
(test-serie "Test d'arguments du type RFLOAT" ())
(←trfloat 5.0) 25.0
(←trfloat 32.0) 1024.
(test-serie "Test d'arguments du type FIXVECTOR" ())
(←ttabint 3 (setq v #[1 2 3])) 3
v #[2 4 6]
(←ttabint 2 v) 2
v #[4 8 6]
#-(featurep '64bitfloats)(test-serie "Test d'arguments du type FLOATVECTOR" ())
#+(featurep '64bitfloats) ()
#+(featurep '64bitfloats)
(test-serie "Pas de test du type FLOATVECTOR en 64BITFLOATS" ())
#-(featurep '64bitfloats) (←ttabflt 3 (setq v #[1.0 2.0 3.3]))
#-(featurep '64bitfloats) 3
#-(featurep '64bitfloats) v
#-(featurep '64bitfloats) #[1.0 4.0 10.89]
(test-serie "Test d'arguments du type T" ())
(setq a 1) 1
(←tlt 'a) 1
(setq a -1) -1
(←tlt 'a) -1
(test-serie "Test d'arguments du type EXTERNAL" ())
(setq a 1) 1
(←tlexternal (loc 'a)) 1
(setq a -1) -1
(←tlexternal (loc 'a)) -1
(test-serie "Test du resultat de type FLOAT" ())
(←tcfloat 0) 0.
(←tcfloat -1) -2.
(←tcfloat 1) 2.
(←tcfloat 32767) 65534.
(←tcfloat -32767) -65534.
(←tcfloat2 0. 0.) 0.
(←tcfloat2 123. 456.) 56088.4102298864848144286
(←f←s←to←d) 2.3
(test-serie "Test du resultat de type STRING" ())
(←tcstring 0) "a"
(←tcstring 1) "ab"
(←tcstring 2) "abc"
(←tcstring 3) "abcd"
(←tcstring 4) ""
(←tcstring -1) "abcdefghijklmnopqrstuvwxyz"
(←tcstring 5) "abcdefghijklmnopqrstuvwxyz"
(test-serie "Test du resultat de type T" ())
(loc (←tct 1)) 1
(loc (←tct -1)) (-1 . -1)
(test-serie "Test du resultat de type EXTERNAL" ())
(←tcexternal 1) 1
(←tcexternal -1) (-1 . -1)
(←tcexternal 1) 1
(test-serie "Tests generaux" ())
; Pour tester le nombre d'arguments et leur ordre
(←tlnadic 1 2 3 4 5 6 7 8 9 10 11) 66
(←tlnadic 11 2 3 4 5 6 7 8 9 10 1) -1
; Pour tester le nbre max d'arguments
(←tnbmaxi 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32) 32
(←tnbmaxf 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. 16.
17. 18. 19. 20. 21. 22. 23. 24. 25. 26. 27. 28. 29. 30. 31. 32.) 32
(←tnbmaxri 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32) 32
(←tnbmaxrf 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. 16.
17. 18. 19. 20. 21. 22. 23. 24. 25. 26. 27. 28. 29. 30. 31. 32.) 32
; Pour tester des mixages de type
(←trfixrfloat 3 5.0) 8.0
#.(setq rv2 (makevector 1000 10.6)) #.rv2
#-(featurep '64bitfloats)
(←ttabother 10
3
(setq v1 #[1 2 3])
1.2
0.5
100
(setq v2 (makevector 1000 10.0))
(setq v3 #[1000 2000 3000 4000])
4
1000)
#-(featurep '64bitfloats) 1000
#-(featurep '64bitfloats) v1
#-(featurep '64bitfloats) #[1010 2010 3010]
#-(featurep '64bitfloats) v2
#-(featurep '64bitfloats) #.rv2
#-(featurep '64bitfloats) v3
#-(featurep '64bitfloats) #[101 102 103 4000]
; Pour tester le dialogue avec une structure globale de C
(and (consp (setq x (←struct←un 1 2. "abc")))
(atom (cdr x))) t
; Pour "presque" tout tester
(←tltout -100 1.2e+3 "hello" #[46] 3) -9341
(neq (←tlmalloc 100) 0) t
(neq (←tlmalloc 1000) 0) t
(neq (←tlmalloc 10000) 0) t
(test-serie "Test de fonctions du lispcaller" ())
(←getsym "concat") concat
(symbolp (←getsym "bar")) t
(eq '←getsym (←getsym "←getsym")) t
(←cons←en←c 1 2) (1 . 2)
(trace cons) (cons)
(←cons←en←c 1 2) (1 . 2)
(untrace) (cons)
(let ((#:sys-package:itsoft (cons 'testgc #:sys-package:itsoft))
(gcalarm ())
(consab ()))
(until gcalarm
(setq consab (←cons←en←c 'a 'b)))
consab) (a . b)
(←cons←en←c 1 2) (1 . 2)
(←vect←to←list #[1 2 3 4 5] 3) (1 2 3)
(←vect←to←list #[] 0) ()
(←vect←to←list #[Q W E R T Y U I O P]
10) (Q W E R T Y U I O P)
(let ((#:sys-package:itsoft (cons 'testgc #:sys-package:itsoft))
(gcalarm ())
(liste ()))
(until gcalarm
(setq liste (←vect←to←list #[Q W E R T Y U I O P] 10)))
liste) (Q W E R T Y U I O P)
(←vect←to←list #[Q W E R T Y U I O P]
10) (Q W E R T Y U I O P)
(←init←fib) 0
(fib 4) 3
(trace fib ←fib) (fib ←fib)
(fib 4) 3
(untrace) (←fib fib)
(fib 20) 6765
(←tlcfloat) 1.2
(←tpastring) 67
(←tlcstring) "concat"
(test-serie "Fin du test" ())
() ()