; .EnTete "Le-Lisp (c) version 15.2" " " "Les appels externes"
; .EnPied "callext.ll" "I-%" " "
; .Annexe I "Les Appels Externes"
; .nr % 1
;
; .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 "*****************************************************************"

; $Header: callext.ll,v 4.9 89/01/11 14:28:19 kuczynsk Exp $

(unless (>= (version) 15.2)
        (error 'load 'erricf 'callext))

(defvar #:sys-package:colon 'system)

(add-feature 'callext)

(de #:system:cached-getglobal (s)
    (if (null #:system:defextern-cache)
        (getglobal s)
      (let ((res (cons 0 0)))
        (newl #:system:getglobal-cache
              (cons s res))
        res)))


; Toutes ces fonctions sont "autoload" dans le syste`me minimum.

(dmd defextern (nom ltype . type)
     (buildextern nom
		  (#:system:cached-getglobal nom)
		  ltype
		  (or (car type) 'fix)))

(de buildextern (nom adr ltype type)
     ; de'fini une proce'dure externe
     (let* (;; compteur d'arguments
	    (n -1)
	    ;; liste des parametres
            (lvar (mapcar (lambda (l)
                             (symbol ':callext
				     (concat "arg" (incr n))))
			  ltype))
	    ;; le corps de la fct de'finie par defextern
            (body `(callextern   ; appel externe
                      (precompile ,(if (numberp adr) adr `',adr)
				  ()
				  ()
				  (eval
				   (kwote (#:system:cached-getglobal ',nom))) )
		      ; numero du type de la valeur rendue
                      ,(:conv-extern-to-ll type)
		      ; plist (parametre1 numero-type1 ...)
                      ,@(mapcan (lambda (type var)
				  (if (eq type 'external)
                                      `((vag ,var) ,(:conv-ll-to-extern type))
				    `(,var ,(:conv-ll-to-extern type))))
                                ltype lvar))
		  ))
       (when (eq type 'external)
	     (setq body `(loc ,body)))
       (if (and (numberp adr) (zerop adr))
	   (error 'defextern 'errudf nom)
	 `(de ,nom ,lvar ,body))) )

(de :conv-ll-to-extern (type)
    ;; Tous ces nume'ros sont e'galement de'crits et utilise's
    ;;  dans llxxx.llm3 spe'cifique a` la machine utilise'e.
    (selectq type
             (external 0)
             (fix 1)
             (float 2)
             (string 3)
             (vector 4)
             (rfix 5)                 ; FIX par reference (FORTRAN)
             (rfloat 6)               ; FLOAT par reference (FORTRAN)
	     (fixvector 7)            ; vecteur d'entiers
	     (floatvector             ; vecteur de flottants.
	      (if (eq 0.0 0.0)        ;  On ne sait pas faire completement
		  8                   ;   les vecteurs de flottants
		(error 'defextern     ;   en 64bitfloats.
		       'errgen
		       "floatvector (64BITFLOATS)")))
             ((t) 0)                  ; T arre^te les clauses!!
             (t (error 'defextern 'erroob type))))

(de :conv-extern-to-ll (type)
    ;; Tous ces nume'ros sont e'galement de'crits et utilise's
    ;;  dans llxxx.llm3 spe'cifique a` la machine utilise'e.
    ;; On ne sait pas ramener un tableau: comment connaitre sa longueur?
    (selectq type
	     (external 0)
	     (fix 1)
	     (float 2)
	     (string 3)
	     ((t) 0)
	     (t (error 'defextern 'errgen type))))

(unless (boundp '#:system:getglobal-cache)
        (defvar #:system:getglobal-cache ()))

(unless (boundp '#:system:defextern-cache)
        (defvar #:system:defextern-cache ()))

(de defextern-cache &nobind
    (selectq (arg)
             (0 #:system:defextern-cache)
             (1
              (when (and (null (arg 0))
                         #:system:defextern-cache)
                    (getglobal-flush-cache))
              (setq #:system:defextern-cache (arg 0)))
             (t (error 'defextern-cache 'errwna 1))))

(de getglobal-flush-cache ()
    (when #:system:getglobal-cache
          (let ((name-list
                 (mapcar (lambda (pair) (string (car pair)))
                         #:system:getglobal-cache))
                (errors ()))
            (_mgetglo name-list ())
            (mapc (lambda (pair value)
                    (if (eq 0 value)
                        (newl errors (car pair))
                      (setq value (loc value))
                      (rplac (cdr pair)
                             (if (fixp value) 0 (car value))
                             (if (fixp value) value (cdr value)))))
                  #:system:getglobal-cache
                  name-list)
            (setq #:system:getglobal-cache ())
            (when errors
                  (error 'defextern 'errudf (nreverse errors))))))

(de cload (s)
    (if #:system:cloadp
        (:ccode (_cload (string s) (:ccode) (:ecode)))
        (error 'cload
               #+ #:system:foreign-language "not implemented in the system"
               #- #:system:foreign-language "non implemente dans le systeme"
               (system))))

(defextern _mgetglo (t t))

#+ #:system:cloadp
(defextern _cload (string external external) external)

; Les tests de lelisp.c :

#|     en enlever en cas de test

(defextern-autoflush ())
   (defextern _cchdir (string) fix)
   (defextern _chome () string)
   (defextern _cmoinsun () fix)
   (defextern _ctest (string float fix vector) float)
(defextern-autoflush t)
   (setq vect #[a b])
   (_ctest "FooBar" 123.45 123 vect)


|#