; .EnTete "Le-Lisp (c) version 15.2" " " "MicroCeyx"
; .EnPied " " "%" " "
; .Chapitre X "Le Ceyx Minimum"
;
; .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: microceyx.ll,v 4.1 88/01/13 12:22:31 kuczynsk Rel $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'microceyx))
#|
Ce chapitre de'crit le microceyx utilise' par CLASSIC et SMECI. Il est
largement inspire' du microceyx de CROAP, qui lui-me↑me est une re'duction
du Ceyx original de Jean-Marie Hullot.
.Section "Majuscules et Minuscules"
Si ce fichier est charge' avec #:SYSTEM:READ-CASE-FLAG a` T le symbole
TCLASS correspond en fait au symbole |Tclass|.
.Section "Compatibilite' Ceyx V4"
Deux indicateurs de chargement permettent de passer progressivement de la
syntaxe CeyxV4 a` la syntaxe CeyxV15, qui est utilise'e par Microceyx. Voir
a` la fin de cette documentation.
.pp
|#
(unless (featurep 'defstruct)
(libload defstruct t))
(setq #:sys-package:colon 'microceyx)
(defvar :ceyxv4-compat ())
(defvar :test-compat ())
#|
.Section "Initialisations"
.Fonction "MICROCEYX\ \ \ \ [FEATURE]"
Ce trait indique que microceyx est charge' dans le syste'me.
.pp
|#
(unless (featurep 'abbrev)
(libload abbrev))
(add-feature 'microceyx)
#|
.Section "Les erreurs spe'cifiques"
Toutes les macros de microceyx ve'rifient le type et la bonne formation de
leurs ope'randes. Elles peuvent de'clencher l'une des erreurs ci-dessous.
.pp
|#
(defvar errnotafield
#- #:system:foreign-language
"l'argument n'est pas un champ de Tclass microceyx"
#+ #:system:foreign-language
"argument not a field of a microceyx Tclass")
(defvar errnotatclass
#- #:system:foreign-language
"l'argument n'est pas un nom de Tclass microceyx"
#+ #:system:foreign-language
"argument not a name of a microceyx Tclass")
(defvar errtclassabbrev
#- #:system:foreign-language
"abre'viation de Tclass microceyx de'ja` de'finie"
#+ #:system:foreign-language
"abbrev of microceyx Tclass already defined")
(defvar errrecordabbrev
#- #:system:foreign-language
"abre'viation de Record microceyx de'ja` de'finie"
#+ #:system:foreign-language
"abbrev of microceyx Record already defined")
(defvar errceyxv4
#- #:system:foreign-language
"syntaxe ceyxv4 : entourez d'accolades Tclass et Record"
#+ #:system:foreign-language
"ceyxv4 syntax: put braces around Tclass and Record")
(defvar errbadfield
#- #:system:foreign-language
"erreur de syntaxe pour un champ"
#+ #:system:foreign-language
"syntax error in field")
(defvar errrecordtoolong
#- #:system:foreign-language
"un Record ne peut pas avoir plus de 16 champs"
#+ #:system:foreign-language
"16 fields maximum per Record")
(defvar errnotarecordoratclass
#- #:system:foreign-language
"l'argument n'est pas un nom de Tclass ou de Record microceyx"
#+ #:system:foreign-language
"argument not a name of microceyx Tclass or Record")
(de :check-record-or-tclass (fn type)
(until (and (symbolp type)
(or (tclass-namep type)
(record-namep type)
(getprop type 'defstruct)))
(setq type (error fn errnotarecordoratclass type)))
type)
(de :check-tclass (fn type)
(until (tclass-namep type)
(setq type (error fn errnotatclass type)))
type)
(de :check-field (fn type field)
(until (and (symbolp field) (getfn type field))
(setq field (error fn errnotafield (list type field))))
field)
#|
.Section "De'finition des structures"
.Fonction "(DEFTCLASS <symbol> <champ1> ... <champN>) \ \ \ [MACRO]"
Cette fonction est identique a` la fonction DEFSTRUCT, la seule diffe'rence
est que le type effectivement de'fini est interne' dans le package Tclass
s'il ne l'e'tait pas de'ja`. De plus le symbole <symbol> du package racine et
de'fini comme abbre'viation pour <symbol> complet.
.DebLL
ex:
(DEFTCLASS FOO A (B 2) C)
(DEFTCLASS {FOO}:BAR (D 4))
correspond a`
(PROGN (LET ((#:SYSTEM:DEFSTRUCT-ALL-ACCESS-FLAG ()))
(DEFSTRUCT #:TCLASS:FOO A (B 2) C))
(DEFABBREV FOO #:TCLASS:FOO))
(PROGN (LET ((#:SYSTEM:DEFSTRUCT-ALL-ACCESS-FLAG ()))
(DEFSTRUCT #:TCLASS:FOO:BAR (D 4)))
(DEFABBREV BAR #:TCLASS:FOO:BAR))
.FinLL
.pp
DEFTCLASS est de'finie en Lisp de la manie`re suivante\ :
|#
(dmd deftclass (type . fields)
(let (type-abbrev)
(until (and (symbolp type)
(or (null (packagecell type))
(tclass-namep (packagecell type))))
(setq type
(error 'deftclass errnotatclass type)))
(when (null (packagecell type))
(setq type (symbol 'Tclass type)))
(setq type-abbrev (symbol || type))
(when (and (abbrevp type-abbrev)
(neq (get-abbrev type-abbrev) type))
(error 'deftclass errtclassabbrev type-abbrev))
`(progn
(defstruct ,type ,.fields)
(defabbrev ,(symbol || type) ,type)
',type)))
#|
.Fonction "(DEFRECORD <symbol> <champ1>...<champN>)\ \ \ \ [MACRO]"
Cette fonction est identique a` la fonction DEFSTRUCT mais les instances
seront implante'es sous la forme d'arbres binaires de cellules de liste bien
e'quilibre's. De plus les instances ne contiendront aucune information de
typage, elles satisfairont uniquement les pre'dicats CONSP et LISTP.
.EspLL
<Symbol> doit e↑tre dans le package racine, il n'y a pas d'he'ritage pour
les records. Par homoge'ne'ite' avec la fonction DEFTCLASS, l'abbre'viation
<symbol> de <symbol> est de'finie.
.EspLL
Un record ne peut pas avoir plus de 16 champs, sinon l'erreur
ERRRECORDTOOLONG est de'clenche'e.
.DebLL
? (DEFRECORD RECFOO A B)
= RECFOO
.FinLL
.pp
DEFRECORD est de'finie en Lisp de la manie`re suivante\ :
|#
(dmd defrecord (name . lfield)
; ve'rifications du nom
(until (and (variablep name)
(null (packagecell name)))
(setq name (error 'defrecord errnva name)))
; pas plus de 16 champs
(when (gt (length lfield) 16)
(error 'defrecord errrecordtoolong `(,name ,@lfield)))
; ve'rification des champs et pose de la valeur initiale () par de'faut
(setq lfield
(mapcar (lambda (f)
(until (or (symbolp f)
(and (consp f)
(symbolp (car f))
(consp (cdr f))
(null (cddr f))))
(setq f
(error 'defrecord errbadfield f)))
(or (consp f)
`(,f ())))
lfield))
; ve'rification que l'abbre'viation n'est pas de'ja` de'finie
(when (and (abbrevp name)
(neq (get-abbrev name) name))
(error 'defrecord errrecordabbrev name))
(let* ((access (ncons ()))
(constructor
(if (cdr lfield)
(:make-field-access name lfield () access)
(:make-single-field-access name lfield access))))
`(progn
(de ,(symbol name 'make) ()
,constructor)
,.(cdr access)
(putprop ',name
',(cons (mapcar 'car lfield) (mapcar 'cadr lfield))
'defrecord)
(defabbrev ,name ,name)
',name)))
(de :make-single-field-access (name lfield access)
(nconc access
(list
`(de ,(symbol name (caar lfield)) &nobind
(if (eq (arg) 1)
(car (arg 0))
(car (rplaca (arg 0) (arg 1)))))
(when (featurep 'compiler)
`(defmacro-open ,(symbol name (caar lfield)) (o . v)
(ifn v
`(car ,o)
`(car (rplaca ,o ,(car v))))))))
`(ncons ,(cadar lfield)))
(de :make-field-access (name lfield cadrs access)
(cond ((null (cdr lfield))
(nconc access (:make-access name (car lfield) cadrs))
(cadar lfield))
(t
`(cons
,(:make-field-access
name
(firstn (div (length lfield) 2) lfield)
(cons 'a cadrs)
access)
,(:make-field-access
name
(nthcdr (div (length lfield) 2) lfield)
(cons 'd cadrs)
access)))))
(de :make-access (name field cadrs)
; La plus belle des backquotes!
`((de ,(symbol name (car field)) &nobind
(if (eq (arg) 1)
(,(implodech `(c ,@cadrs r)) (arg 0))
(,(implodech `(c ,(car cadrs) r))
(,(concat "rplac" (car cadrs))
,(if (cdr cadrs)
`(,(implodech `(c ,@(cdr cadrs) r)) (arg 0))
`(arg 0))
(arg 1)))))
,@(when (featurep 'compiler)
`((defmacro-open ,(symbol name (car field)) (o . v)
(ifn v
`(,',(implodech `(c ,@cadrs r)) ,o)
,(if (cdr cadrs)
``(,',(implodech `(c ,(car cadrs) r))
(,',(concat "rplac" (car cadrs))
,`(,',(implodech `(c ,@(cdr cadrs) r)) ,o)
,(car v)))
``(,',(implodech `(c ,(car cadrs) r))
(,',(concat "rplac" (car cadrs))
,o ,(car v))))))))))
#|
.Fonction "(TCLASS-NAMEP symbol) \ \ \ [SUBR a` 1 argument]"
Ce pre'dicat est vrai si son argument est le nom d'une classe de'finie par
DEFTCLASS.
.DebLL
ex:
(TCLASS-NAMEP '#:TCLASS:FOO) --> T
(TCLASS-NAMEP '{BAR}) --> T
(TCLASS-NAMEP 'foothebarre) --> ()
(TCLASS-NAMEP '(foo bar)) --> ()
.FinLL
.pp
TCLASS-NAMEP est de'finie en Lisp de la manie`re suivante\ :
|#
(de tclass-namep (type)
(when
(and (symbolp type)
(subtypep type 'Tclass)
(getprop type 'defstruct))
t))
#|
.Fonction "(RECORD-NAMEP <symbol>) \ \ \ \ [SUBR a` 1 argument]"
Ce pre'dicat est vrai si l'argument est le nom d'un record de'fini par
DEFRECORD.
.DebLL
ex :
? (RECORD-NAMEP 'FOO)
= T
? (RECORD-NAMEP 'BAR)
= ()
? (RECORD-NAMEP '(1 2 3))
= ()
.FinLL
.pp
RECORD-NAMEP est de'fini en Lisp de la manie`re suivante\ :
|#
(de record-namep (name)
(when (and (symbolp name)
(getprop name 'defrecord))
t))
#|
.Fonction "(FIELD-LIST symbol) \ \ \ [SUBR a` 1 argument]"
retourne la liste des noms des champs des instances de la Tclass de nome
symbol. Symbol doit e↑tre un nom valide de Tclass (pas une abbre'viation).
.DebLL
ex:
(FIELD-LIST '{FOO}) --> (A B C)
(FIELD-LIST '#:TCLASS:FOO:BAR) --> (A B C D)
.FinLL
.pp
FIELD-LIST est de'finie en Lisp de la manie're suivante\ :
|#
(de field-list (type)
(setq type (:check-record-or-tclass 'field-list type))
(if (record-namep type)
(car (getprop type 'defrecord))
(:tclass-field-list type ())))
(de :tclass-field-list (type res)
(cond ((null type) res)
((eq type 'Tclass) res)
(t
(:tclass-field-list
(packagecell type)
(append (cdr (getprop type 'defstruct)) res)))))
#|
.Section "Instances des Tclass et des Record"
.Fonction "(DEFMAKE type fn (field1...fieldN))\ \ \ [MACRO]"
de'fini la fonction fn comme construisant une instance de la Tclass ou
du Record type. Fn recoit N arguments qui sont les valeurs des champs
de nom fieldI de l'instance cre'e'e.
.DebLL
ex:
? (DEFMAKE {FOO} MAKE-FOO (C A))
= MAKE-FOO
? (SETQ X (MAKE-FOO 12 34))
= #:TCLASS:FOO:#[34 2 12]
? ({FOO}:A X)
= 34
? ({FOO}:C X)
= 12
.FinLL
.pp
DEFMAKE est de'fini en Lisp de la manie`re suivante\ :
|#
(dmd defmake (type fn larg)
(until (variablep fn)
(setq fn (error 'defmake errsym fn)))
`(de ,fn ,larg
(omakeq ,type ,.(mapcan (lambda (arg) (list arg arg)) larg))))
#|
.Fonction "(OMAKEQ type field1 val1 ... fieldN valN)\ \ \ [MACRO]"
Retourne une instance de la Tclass type dont les champs fieldI ont les
valeurs valI. Type et les fieldI ne sont pas e'value's.
.DebLL
ex :
(OMAKEQ {BAR}) ---> #:TCLASS:FOO:BAR:#[() 2 () 4]
(OMAKEQ {BAR} A 3) ---> #:TCLASS:FOO:BAR:#[3 2 () 4]
.FinLL
.pp
OMAKEQ est de'finie en Lisp de la manie're suivante\ :
|#
(dmd omakeq (type . varval)
(let ((init-forms ())
var val)
#+ :ceyxv4-compat
(setq type (plink type))
#+ :test-compat
(when (and (symbolp type)
(null (packagecell type)))
(error 'omakeq errceyxv4 type))
(setq type (:check-record-or-tclass 'omakeq type))
(while (consp varval)
(setq var (:check-field 'omakeq type (nextl varval)))
(unless (consp varval)
(error 'omakeq (ifn varval errwna errbpa) varval))
(nextl varval val)
(setq init-forms
`((,(getfn type var) :res ,val) ,.init-forms)))
(unless (null varval)
(error 'omakeq errbpa varval))
`(let ((:res (,(symbol type 'make))))
,.(nreverse init-forms)
:res)))
#|
.Fonction "(OGETQ tclass-or-record field obj) \ \ \ [MACRO]"
.Fonction "(OPUTQ tclass-or-record field obj val) \ \ \ [MACRO]"
.Fonction "(OMATCHQ tclass obj) \ \ \ \ [MACRO]"
Ces fonctions sont identiques aux fonctions Ceyx correspondantes.
.DebLL
ex:
(OGETQ {FOO} B (OMAKEQ {FOO})) --> 2
(OGETQ {RECFOO} B (OMAKEQ {RECFOO} b 48)) --> 48
(OMATCHQ {FOO} (OMAKEQ {BAR})) --> T
.FinLL
.pp
Elles sont de'finies en Lisp de la manie`re suivante\ :
|#
(dmd ogetq (type field obj)
#+ :ceyxv4-compat
(setq type (plink type))
#+ :test-compat
(when (and (symbolp type)
(null (packagecell type)))
(error 'ogetq errceyxv4 type))
(setq type (:check-record-or-tclass 'ogetq type))
(setq field (:check-field 'ogetq type field))
`(,(getfn type field) ,obj))
(dmd oputq (type field obj val)
#+ :ceyxv4-compat
(setq type (plink type))
#+ :test-compat
(when (and (symbolp type)
(null (packagecell type)))
(error 'ogetq errceyxv4 type))
(setq type (:check-record-or-tclass 'oputq type))
(setq field (:check-field 'oputq type field))
`(,(getfn type field) ,obj ,val))
(dmd omatchq (type obj)
#+ :ceyxv4-compat
(setq type (plink type))
#+ :test-compat
(when (and (symbolp type)
(null (packagecell type)))
(error 'ogetq errceyxv4 type))
(setq type (:check-tclass 'omatchq type))
`(typep ,obj ',type))
#|
.Section "Me'thodes et envoi de messages"
.Fonction "(DEMETHOD {tclass}:name (obj p1...pN) (f1...fN) . body)\ \ \ [MACRO]"
F1...fN sont des champs de la Tclass de nom {tclass}.
.DebLL
(DEFMETHOD {FOO}:GEE (OBJ X Y Z) (A B)
<BODY>)
est e'quivalent a`
(DE {FOO}:GEE (OBJ X Y Z)
(LET ((A ({FOO}:A OBJ))
(B ({FOO}:B OBJ)))
<BODY>))
.FinLL
|#
(dmd demethod (name (obj . pars) fields . body)
(until (symbolp name)
(setq name (error 'demethod errsym name)))
(let ((tclass (:check-record-or-tclass 'demethod (packagecell name))))
(unless (listp fields)
(error 'demethod errnla fields))
`(de ,name (,obj ,@pars)
,@(ifn fields
body
`((let
,(mapcar
(lambda (f)
(setq f
(:check-field
'demethod tclass f))
`(,f (,(getfn tclass f) ,obj)))
fields)
,@body))))))
#|
.Fonction "(SEND message objet par1 ... parN) \ \ \ [SUBR a` N arguments]"
.Fonction "(SENDQ message objet par1 ... parN) \ \ \ [MACRO]"
Cette fonction est identique a` la fonction standard SEND sauf qu'en
microceyx elle recherche les me'thodes jusqu'au package racine exclus, puis,
en cas d'e'chec recherche dans les packages * puis ||.
.EspLL
SENDQ est identique a` SEND mais son premier argument n'est pas e'value'.
.EspLL
La recherche des me'thodes de la fonction SEND est implante'e en
rede'finissant la fonction SEND-ERROR de la manie`re suivante\ :
.pp
|#
(de send-error (sem argslist)
(let ((fun (getfn '* sem)))
(if fun
(apply fun argslist)
(error 'send errudm (cons sem argslist)))))
(dmd sendq (message . rest)
`(send ',message ,.rest))
#|
.Fonction "(SENDF <message> <par1>...<parN>)\ \ \ [MACRO]"
.Fonction "(SENDFQ <message> <par1>...<parN>)\ \ \ [MACRO]"
Ge'ne`re une fonctions a` un argument (LAMBDA) transmettant le message
<message> avec les parame`tres <parI> a` son argument. Cette fonction est
particulie'rement utile pout MAPper la fonction SEND.
.EspLL
SENDFQ est identique a` SENDF mais son premier argument n'est pas e'value'.
.DebLL
ex :
? (DE {FOO}:GOO (o a)
? (PRINT "{FOO}:GOO " ({FOO}:b o) " " a))
= {FOO}:GOO
? (MAPC (SENDF 'GOO 12) (LIST (OMAKEQ {FOO} b 14) (OMAKEQ {FOO} b 20)))
{FOO}:GOO 14 12
{FOO}:GOO 20 12
= ()
.FinLL
|#
(dmd sendf (func . args)
`(lambda (:arg1) (send ,func :arg1 ,.args)))
(dmd sendfq (func . args)
`(sendf ',func ,.args))
#|
.Section "Compatibilite' avec CeyxV4"
.SSection "Fonctions de CeyxV4"
Les deux fonctions ci-dessous ne sont pre'sentes que lorsque l'indicateur de
compatibilite' CeyxV4 est positionne'. Si l'indicateur n'est pas positionne'
ces fonctions n'existent pas. Si l'indicateur de test de compatibilite' est
positionne' ces fonctions de'clenchent l'erreur ERRCEYXV4.
.Fonction "(PLINK symbol abbrev) \ \ \ [SUBR a` 1 ou 2 arguments]"
Avec un seul argument rend l'abbre'viation associe' a` cet argument, ou
l'argument s'il n'a pas de de'finition d'abbre'viation. Avec deux arguments
cette fonction est identique a` la fonction PUT-ABBREV.
Cette fonction ne fait aucun test de validite' de son premier argument qui
doit e↑tre un symbole. Elle n'existe que par compatibilite' avec CeyxV4; il
vaut mieux utiliser le package d'abbre'viations directement.
.DebLL
ex:
(PLINK 'FOO) ---> #:TCLASS:FOO
(PLINK 'GEEMUCHE) ---> GEEMUCHE
(PLINK 'A 'B)
(PLINK 'A) ---> B
.FinLL
.pp
PLINK est de'finie en Lisp de la manie're suivante\ :
|#
(de plink (s . v)
(ifn v
(if (abbrevp s) (get-abbrev s) s)
(put-abbrev s (car v))))
#|
.Fonction "(<=P type1 type2)\ \ \ [SUBR a` 2 arguments]"
Cette fonction compare deux symboles package's selon la hie'rarchie des
packages. Elle n'existe que par compatibilite' CeyxV4, il vaut mieux
utiliser la fonction SUBTYPEP.
.pp
Elle est de'finie en Lisp de la manie`re suivante\ :
|#
(dmd <=p (p1 p2)
`(subtypep ,p1 ,p2))
#|
.SSection "Syntaxe CeyxV4"
En CeyxV4 les accolades autour des noms de Tclass e'taient optionelles pour
les fonction OGETQ/OPUTQ/OMATCHQ et OMAKEQ. Ceci est autorise' en microceyx
lorsque l'indicateur
:CEYXV4-COMPAT est positionne'. Si cet indicateur n'est pas positionne'
et si l'indicateur :TEST-COMPAT est positionne' ces fonctions de'clenchent
l'erreur ERRCEYXV4 si l'on a oublie' les accolades.
.SSection "Les indicateurs de compatibilite'"
Les indicateurs sont de'finis dans ce fichier (les deux DEFVAR en te↑te de
fichier). Pour modifier un indicateur il faut e'diter ce fichier et donner
une valeur T (indicateur positionne') ou () (indicateur non positionne') a`
l'indicateur choisi.
En vue de l'utilisation de microceyx en Le←Lisp V16, il est recommande' de
modifier ses sources pour ne plus utiliser l'indicateur de compatibilite'.
|#