; .EnTete "Le-Lisp (c) version 15.2" " " "Les Macros du Compilateur"
; .EnPied " " "%" " "
; .sp 2
; .SuperTitre "Les Macros du Compilateur"
;
; .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: cpmac.ll,v 4.6 88/12/27 01:42:49 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'cpmac))
; Les macros de l'interpre`te (DM et DMD) sont une tre`s bonne chose
; pour le compilateur qui ne va compiler que le re'sultat des
; expansions. Cette technique est si bonne qu'on va rede'finir
; des fonctions standard sous forme de macros spe'ciales, les
; \fImacros du compilateur\fR. Il en existe de 2 sortes\ :
; .br
; - les macros ferme'es (:macro-close) qui sont toujours exe'cute'es
; .br
; - les macros ouvertes (:macro-open) qui ne sont exe'cute'es que si
; l'indicateur global :OPEN-P est vrai.
; .Section "Les Variables Globales"
; Tous les symboles pre'fixe's par : seront cre'e's dans le
; package COMPILER.
(defvar #:sys-package:colon 'compiler)
; #:compiler:open-p : indique que les compilations open
; (voir la section suivante) sont autorise'es.
; Une compilation open peut donner des re'sultats
; diffe'ents de ceux de l'interpre`te en cas de mauvais type d'arguments.
(defvar :open-p t)
; .Section "De'finitions des Macros"
(df defmacro-open (name . fval)
(setfn (symbol name 'macro-open) 'expr fval)
name)
(de make-macro-open (nom fval)
(setfn (symbol nom 'macro-open) 'expr fval)
nom)
(de macro-openp (nom)
(getfn1 nom 'macro-open))
(de remove-macro-open (nom)
(when (getsymb1 nom 'macro-open)
(remob (getsymb1 nom 'macro-open))))
; .Section "Les Fonctions Exporte'es"
(de :macro-expand-error (l)
; peut (et doit) e↑tre rede'finie
(error ':macro-expand-error "erreur durant la macroexpansion" l))
(de :macroexpand (l)
; expanse la forme <l>.
(if (and (consp l) (symbolp (car l)))
(let ((x ()) (cl (car l)) (cd (cdr l)))
(setq x (catcherror ()
(cond
((and :open-p (setq x (getfn1 cl 'macro-open)))
; Macros ouvertes du compilateur.
; Si elle retourne (), la macro est surcharge'e
; et n'est plus effective.
(or (apply x (cdr l))
l))
; Les macros internes pre'de'finies
((:macroexpand-internal cl (cdr l)))
((eq (typefn cl) 'macro)
; Macros utilisateurs.
(apply (cons 'lambda (valfn cl)) l) )
((eq (typefn cl) 'dmacro)
; Displace macros utilisateurs.
(apply (cons 'lambda (valfn cl)) (cdr l)) )
((eq (typefn cl) 'msubr)
; Macros syste`mes ou utilisateurs compile'es.
(call (valfn cl) l () ()) )
((eq (typefn cl) 'dmsubr)
; Displace macros syste`mes ou utilisateurs compile'es.
(call (valfn cl) (cdr l) () ()) )
(t l) )))
(cond
; Une macro a produit une erreur (catcherror)
((atom x) (:macro-expand-error cl))
; Test si la macro expansion a fait quelquechose
; et me↑me pour les vicieux qui travaillent directement
; sur la forme a` expanser.
((and (consp (car x))
(or (neq l (car x))
(neq cl (caar x))
(neq cd (cdar x))))
(:macroexpand (car x)))
; Sinon on retourne le me↑me objet.
(t (car x))))
l))
; .Section "Les Expansions internes"
(de :macroexpand-internal (fnt l)
(or (and :open-p (:macroexpand-internal-open fnt l))
(:macroexpand-internal-close fnt l) ))
(de :macroexpand-internal-close (fnt l)
(selectq fnt
(COND (:mc:cond l))
(UNLESS `(if (not ,(car l)) (progn ,@(cdr l))))
(WHEN `(if ,(car l) (progn ,@(cdr l))))
(IFN `(if (not ,(car l)) ,@(cdr l)))
(NEQ `(not (eq ,@l)))
(NEQUAL `(not (equal ,@l)))
(NULL `(not ,@l))
(ATOMP `(atom ,@l))
(DECR `(setq ,(car l) (,(if (cdr l) '- '1-) ,@l)))
(INCR `(setq ,(car l) (,(if (cdr l) '+ '1+) ,@l)))
(NEWL `(setq ,(car l) (cons ,(cadr l) ,(car l))))
(NEXTL `(prog1
,(if (cdr l)
`(setq ,(cadr l) (car ,(car l)))
`(car ,(car l)))
(setq ,(car l) (cdr ,(car l))) ))
(NEWR `(setq ,(car l)
(let ((:newr ,(cadr l)))
(nconc ,(car l) (ncons :newr)))))
(DYNAMIC-LET (:mc:dynamic-let l))
(DYNAMIC (:mc:dynamic l))
(RETURN `(return-from () ,@l))
(MAP (:map l 'map 'null))
(MAPL (:map l 'map 'null))
(MAPLIST (:map l 'map 'cons))
(MAPCON (:map l 'map 'nreconc))
(MAPC (:map l 'mapc 'null))
(MAPCAR (:map l 'mapc 'cons))
(MAPCAN (:map l 'mapc 'nreconc))
(EVERY (:map l 'mapc 'every))
(ANY (:map l 'mapc 'any))
(MAPVECTOR (:mapvector l))
(UNTILEXIT `(tag ,(car l) (while t ,@(cdr l))))
(LOOP `(while t ,@l))
(CATCHERROR (:mc:catcherror l))
(ERRSET (:mc:errset l))
(ERR `(exit #:system:error-tag ,@l))
(EVAL-WHEN (:mc:eval-when l))
(DESETQ `(deset ',(car l) ,(cadr l)))
(DEFPROP `(putprop ',(car l) ',(cadr l) ',(caddr l)))
(PSETQ (if (cddr l)
`(setq ,(car l)
(prog1 ,(cadr l) (psetq ,.(cddr l))) )
`(setq ,(car l) ,(cadr l))) )
(SETQQ (if (cddr l)
`(progn
(setq ,(car l) ',(cadr l))
(setqq ,.(cddr l)) )
`(setq ,(car l) ',(cadr l)) ))
(LETVQ `((lambda (,(car l)) ,@(cddr l)) ,(cadr l)))
(PROG2 `(progn ,(car l) (prog1 ,@(cdr l))))
(LOGNOT `(logxor ,(car l) -1))
(ADD1 `(add ,(car l) 1))
(SUB1 `(sub ,(car l) 1))
(TIME (:mc:time (car l)))
(t ()) ))
(de :macroexpand-internal-open (fnt l)
(selectq fnt
(CAAR `(car (car ,.l)))
(CADR `(car (cdr ,.l)))
(CDAR `(cdr (car ,.l)))
(CDDR `(cdr (cdr ,.l)))
(CAAAR `(car (car (car ,.l))))
(CAADR `(car (car (cdr ,.l))))
(CADAR `(car (cdr (car ,.l))))
(CADDR `(car (cdr (cdr ,.l))))
(CDAAR `(cdr (car (car ,.l))))
(CDADR `(cdr (car (cdr ,.l))))
(CDDAR `(cdr (cdr (car ,.l))))
(CDDDR `(cdr (cdr (cdr ,.l))))
(CAAAAR `(car (car (car (car ,.l)))))
(CAAADR `(car (car (car (cdr ,.l)))))
(CAADAR `(car (car (cdr (car ,.l)))))
(CAADDR `(car (car (cdr (cdr ,.l)))))
(CADAAR `(car (cdr (car (car ,.l)))))
(CADADR `(car (cdr (car (cdr ,.l)))))
(CADDAR `(car (cdr (cdr (car ,.l)))))
(CADDDR `(car (cdr (cdr (cdr ,.l)))))
(CDAAAR `(cdr (car (car (car ,.l)))))
(CDAADR `(cdr (car (car (cdr ,.l)))))
(CDADAR `(cdr (car (cdr (car ,.l)))))
(CDADDR `(cdr (car (cdr (cdr ,.l)))))
(CDDAAR `(cdr (cdr (car (car ,.l)))))
(CDDADR `(cdr (cdr (car (cdr ,.l)))))
(CDDDAR `(cdr (cdr (cdr (car ,.l)))))
(CDDDDR `(cdr (cdr (cdr (cdr ,.l)))))
(t ()) ))
; Ceci enleve' (dans la passe' une erreur des plus vicieuses.
; A vous de la trouver!!
; (:macroexpand '(trouver l erreur))
; .Section "Fonctions Spe'cialis'es (ordre alpha)"
(de :mc:catcherror ((s . l))
(cond
((eq s t)
`(let ((#:system:error-flag t))
(tag #:system:error-tag (ncons (progn ,@l))) ))
((null s)
`(let ((#:system:error-flag ())
(#:system:print-msgs 0)
(#:system:debug ()))
(tag #:system:error-tag (ncons (progn ,@l))) ))
(t `(let ((#:system:error-flag (eval ,s)))
(let ((#:system:print-msgs
(if #:system:error-flag #:system:print-msgs 0))
(#:system:debug
(if #:system:error-flag #:system:debug ()) ))
(tag #:system:error-tag
(ncons (progn ,@l))) )))))
(de :mc:cond (l)
(if (null (cdr l))
(if (cdar l)
(if (eq (caar l) t)
`(progn ,@(cdar l))
`(if ,(caar l) (progn ,@(cdar l))) )
(or (caar l) 'nil) )
(if (cdar l)
`(if ,(caar l) (progn ,@(cdar l)) (cond ,@(cdr l)))
`(or ,(caar l) (cond ,@(cdr l))) )))
(de :mc:dynamic (l)
;; un reference variable dynamique.
(when (featurep 'complice) (putprop (car l) t dynamic-flag))
(car l))
(de :mc:dynamic-let (l)
;; produire une liaison dynamique.
;; llcp le fait par de'faut, mais on doit l'indiquer a` complice.
(when (featurep 'complice)
(mapc (lambda ((var val))(putprop var t dynamic-flag))
(car l)))
`(let ,(car l) ,@(cdr l)))
;;; Par compatibilite', complice regard loaded-from-file pour de'cider
;;; s'il faut lier dynamiquement.
(defvar dynamic-flag '#:system:loaded-from-file)
(defvar :exported-env ())
(de :mc:eval-when ((S* . E*))
(let ( (ret 'nil) )
(cond
((memq 'load S*) (setq ret `(progn ,@E*)))
((memq 'local-compile S*) (eprogn E*))
((memq 'compile S*)
(eprogn E*)
(unless (member E* :exported-env) (newl :exported-env E*)) ))
ret ))
(de :mc:errset ((l s))
`(let ((#:system:error-flag ,s))
(tag #:system:error-tag (ncons ,l)) ))
; .Section "Les spe'cialistes de l'expansion des fonctionnelles"
(de :map ((fnt . larg) targ tret)
(let ((n (length larg)) (glarg ()) (res '#:system:map:r))
(repeat n
(newl glarg (symbol '#:system:map (concat "arg" (decr n)))))
`((lambda ,glarg
,(:map-result
(:map-while
(:map-next-res (:map-funcall (:map-next-arg glarg targ)
fnt)
tret
res)
tret
(mapcar (lambda (m) `(consp ,m)) glarg))
tret res ))
,@larg )))
(de :mapvector ((fnt v))
`(let* ((#:system:map:r 0)
(#:system:map:v ,v)
(#:system:map:n (vlength #:system:map:v)))
(while (lt #:system:map:r #:system:map:n)
,(:map-funcall '((vref #:system:map:v #:system:map:r)) fnt)
(setq #:system:map:r (add1 #:system:map:r)))))
(de :map-next-arg (larg type-arg)
(mapcar
(lambda (m)
`(prog1 ,(if (eq type-arg 'map) m `(car ,m)) (setq ,m (cdr ,m))) )
larg ))
(de :map-funcall (corps fnt)
(cond ((not (consp fnt)) (mcons 'funcall fnt corps))
((memq (car fnt) '(function quote))
(if (and (symbolp (cadr fnt))
(memq (typefn (cadr fnt)) '(() fexpr fsubr)) )
(mcons 'funcall fnt corps)
(cons (cadr fnt) corps) ))
((eq (car fnt) 'lambda) (cons fnt corps))
((eq (car fnt) 'flambda) (cons (cons 'lambda (cdr fnt)) corps))
; Ge'ne're une erreur a` l'interpre'tation.
((eq (car fnt) 'mlambda) (mcons 'funcall fnt corps))
(t (mcons 'funcall fnt corps)) ))
(de :map-next-res (exp type-result res)
(selectq type-result
(null exp)
(cons `(setq ,res (cons ,exp ,res)))
(nreconc `(setq ,res (nreconc ,exp ,res)))
(t `(setq ,res ,exp)) ))
(de :map-while (exp type-result glarg)
(selectq type-result
((null cons nreconc) `(while (and ,@glarg) ,exp))
(every `(while (and ,@glarg ,exp)))
(any `(while (and ,@glarg (not ,exp)))) ))
(de :map-result (exp type-result res)
(selectq type-result
(null exp)
((cons nreconc) `((lambda (,res) ,exp (nreverse ,res)) ()))
(every `((lambda (,res) ,exp ,res) t))
(any `((lambda (,res) ,exp ,res) ())) ))
(defun :mc:time (e)
(if (and (consp e) (eq (car e) 'quote))
`(let ( (:time (runtime)) ) ,(cadr e) (fsub (runtime) :time))
`(let ( (:time (runtime)) ) (eval ,e) (fsub (runtime) :time))))