Author: ctian
Date: Tue Mar 22 02:17:32 2011
New Revision: 20
Log:
Created branch cl-xml-legacy. (saving the head to moving trunk forward to ASDF-based systems)
Added:
branches/legacy/
- copied from r19, /trunk/
1
0
[cl-xml-cvs] Is Israel a Democracy? -- The problem with intellectually insecure whites -- Should Christians Support Israeli Terrorism in Gaza?
by Lawrence Auster 23 Jan '09
by Lawrence Auster 23 Jan '09
23 Jan '09
The Jewish State of Israel has no constitution, nor does it name its borders. Israel's hidden constitution is Judaism. Israel's undeclared borders range from the Nile to the Euphrates rivers. Israel's desired jurisdiction extends over the entire Earth.
It could not be more clear that the Jewish State follows a foreign policy which obeys Jewish Law as iterated in the Hebrew Bible, the Talmud, Maimonedes, the Cabalah, and the many commentaries and refinements of same. The Jews are genociding the native inhabitants of Palestine, just as their religion advises, and because
their religion teaches them to do so. They treat non-Jews as if non-humans, just as their religion requires them to do. They make perpetual war on every nation on Earth, just as their genocidal Jewish God has instructed.
The Jews of Israel are simply being Jews. Jews are an existential threat to the human race.
Israel contains one third of the Jews of the World. It is not some aberration of the Jewish spirit, but the condensation and concentration of the perverse Jewish mentality, which malady also pervades the remaining two thirds of Jewry, who almost unanimously support the Jewish State, and who certainly do unanimously support
the Jewish People and its consistent and constant crimes against the human race. Israel is Jewry and the danger of Israel is the danger of the Jewish People to all others, as the Jews have demonstrated each and every day of their existence.
The Jews, the entire Jewish People of 15 million, will not relent until they have wiped out all non-Jews in "Greater Israel". They will not stop destroying all other cultures, nations, religions, ethnicities, races, competition, etc. until they are either stopped, or succeed in their ancient quest to destroy the human race.
What Israel is doing is not some reaction to outside forces, nor was the formation of Israel a response to the Holocaust. Israel is simply following the plan laid out in the Jews' religious texts. The Jews have openly planned to take Palestine and genocide the native population of Palestine for some 2,500 years before the
Holocaust. The Jews have openly complained that "anti-Semitism" is a threat that gives them the right to genocide the Palestinians, not merely since the advent of Nazism, but for some 2,500 years.
The Jewish religion is the Constitution of the Jewish State of Israel, and, to a greater or lesser extent, the constitution of the nature of every Jew alive. The borders of Israel are the range the Jew roams over the entire World. The perverse Jewish mentality is inbred by a Jew's exposure to his parents and to his community. Judaism
passes in the spit and slobber of Jewish mother telling her Jewish child that he is a "Jew", as much as Judaism passes in the poison and pain of a Talmudic tractate. The secular Jews did not suddenly come to life after the Enlightenment and the Jewish Reformation a body of vampires that appeared ex nihilo, in vacuo, mostly
atheistical and undetached from formally practiced Judaism. Judaism is the Jew. It is a mindset that transcends and supercedes religion. It is a belief set, a way of life, a perception of one's self and one's relation to the World that makes a Jew, a Jew, and a danger to all of humanity.
In fact, the religious shell of Judaism is like the stretched and infected skin of a lycanthropic pustule. When you lance it to cure the infection, the virus only becomes more contagious and spills directly on the non-Jew.
The secular Jew is a deliberate product of the hyper-religious Jew, a monster created out of the hewed corpses of the fanatically religious Jew, a Golem which is conjured up to enter the World of the non-Jew and poison its blood, and boil its brain with a rabid lunacy that bites and spreads, until the infected community feeds on
itself and fills the fields with rotting bloating bodies, where once human beings tilled the soil and tended to their families. The religious Jew created the secular Jew as an army of Esthers who seduce with open thighs, broad smiles, and a Siren call that lures in the non-Jew to cast his skull upon the jagged rocks and color the seas
with his blood, sickened and blinded by the venereal disease of Judaism in secular form.
Israel is not a secular democracy. It is a religious mockery. It is a rabid bat flying to the ends of the Earth, to end the Earth. No one will be free nor safe until the disease is quarantined and dies out.
Source: http://www.ziopedia.org/articles/israel/how_can_israel_claim_to_be_a_%27dem…
--------------------
The problem with intellectually insecure whites
By Kevin MacDonald
January 19, 2009
America will soon have a white minority. This is a much desired state of affairs for the hostile elites who hold political power and shape public opinion. But it certainly creates some management issues � at least in the long run. After all, it�s difficult to come up with an historical example of a nation with a solid ethnic majority (90%
white in 1950) that has voluntarily decided to cede political and cultural power. Such transformations are typically accomplished by military invasions, great battles, and untold suffering.
And it�s not as if everyone is doing it. Only Western nations view their own demographic and cultural eclipse as a moral imperative. Indeed, as I have noted previously, it is striking that racial nationalism has triumphed in Israel at the same time that the Jewish intellectual and political movements and the organized Jewish
community have been the most active and effective force for a non-white America. Indeed, a poll in 2008 found that Avigdor Lieberman was the second most popular politician in Israel. Lieberman has advocated expulsion of Arabs from Israel and has declared himself a follower of Vladimir Jabotinsky, the leading pioneer of racial
Zionism. The most popular politician in the poll was Benjamin Netanyahu � another admirer of Jabotinsky. Prime Minister Ehud Olmert and Foreign Minister Tzipi Livni are also Jabotinskyists.
The racial Zionists are now carrying out yet another orgy of mass murder after a starvation-inducing blockade and the usual triggering assault designed to provoke Palestinian retaliation � which then becomes the cover for claims that Israel is merely defending itself against terrorism. This monstrosity was approved by
overwhelming majorities of both Houses of Congress. The craven Bush administration did its part by abstaining from a UN resolution designed by the US Secretary of State as a result of a personal appeal by the Israeli Prime Minister. This is yet another accomplishment of the Israel Lobby, but one they would rather not have
discussed in public. People might get the impression that the Lobby really does dictate US foreign policy in the Mideast. Obviously, such thoughts are only entertained by anti-Semites.
But I digress.
In managing the eclipse of white America, one strategy of the mainstream media is to simply ignore the issue. Christopher Donovan (�For the media, the less whites think about their coming minority status, the better�) has noted that the media, and in particular, the New York Times, are quite uninterested in doing stories that
discuss what white people think about this state of affairs.
It�s not surprising that the New York Times � the Jewish-owned flagship of anti-white, pro-multicultural media � ignores the issue. The issue is also missing from so-called conservative media even though one would think that conservatives would find the eclipse of white America to be an important issue. Certainly, their audiences
would find it interesting.
Now we have an article �The End of White America� written by Hua Hsu, an Assistant Professor of English at Vassar College. The article is a rather depressing display of what passes for intellectual discourse on the most important question confronting white people in America.
Hsu begins by quoting a passage in F. Scott Fitzgerald�s The Great Gatsby in which a character, Tom Buchanan, states: �Have you read The Rise of the Colored Empires by this man Goddard?� � Well, it�s a fine book, and everybody ought to read it. The idea is if we don�t look out the white race will be�will be utterly submerged.
It�s all scientific stuff; it�s been proved.�
Buchanan�s comment is a thinly veiled reference to Lothrop Stoddard�s The Rising Tide of Color which Hsu describes as �rationalized hatred� presented in a scholarly, gentlemanly, and scientific tone. (This wording that will certainly help him when he comes up for tenure.) As Hsu notes, Stoddard had a doctorate from Harvard
and was a member of many academic associations. His book was published by a major publisher. It was therefore �precisely the kind of book that a 1920s man of Buchanan�s profile � wealthy, Ivy League�educated, at once pretentious and intellectually insecure � might have been expected to bring up in casual conversation.�
Let�s ponder that a bit. The simple reality is that in the year 2009 an Ivy League-educated person, "at once pretentious and intellectually insecure," would just as glibly assert the same sort of nonsense as Hsu. To wit:
The coming white minority does not mean that the racial hierarchy of American culture will suddenly become inverted, as in 1995�s White Man�s Burden, an awful thought experiment of a film, starring John Travolta, that envisions an upside-down world in which whites are subjugated to their high-class black oppressors. There will
be dislocations and resentments along the way, but the demographic shifts of the next 40 years are likely to reduce the power of racial hierarchies over everyone�s lives, producing a culture that�s more likely than any before to treat its inhabitants as individuals, rather than members of a caste or identity group.
The fact is that no one can say for certain what multicultural America without a white majority will be like. There is no scientific or historical basis for claims like �the demographic shifts of the next 40 years are likely to reduce the power of racial hierarchies over everyone�s lives, producing a culture that�s more likely than any before
to treat its inhabitants as individuals, rather than members of a caste or identity group.�
Indeed, there is no evidence at all that we are proceeding to a color blind future. The election results continue to show that white people are coalescing in the Republican Party, while the Democrats are increasingly the party of a non-white soon-to-be majority.
Is it so hard to believe that when this coalition achieves a majority that it will further compromise the interests of whites far beyond contemporary concerns such as immigration policy and affirmative action? Hsu anticipates a colorblind world, but affirmative action means that blacks and other minorities are certainly not treated as
individuals. And it means that whites � especially white males � are losing out on opportunities they would have had without these policies and without the massive non-white immigration of the last few decades.
Given the intractability of changing intelligence and other traits required for success in the contemporary economy, it is unlikely that 40 more years of affirmative action will attain the outcomes desired by the minority lobbies. Indeed, in Obama's America, blacks are rioting in Oakland over perceived racial injustices, and from 2002
�2007, black juvenile homicide victims increased 31%, while black juvenile homicide perpetrators increased 43%. Hence, the reasonable outlook is for a continuing need for affirmative action and for racial activism in these groups, even after whites become a minority.
Whites will also lose out because of large-scale importation of relatively talented immigrants from East Asia. Indeed, as I noted over a decade ago, "The United States is well on the road to being dominated by an Asian technocratic elite and a Jewish business, professional, and media elite."
Hsu shows that there already is considerable anxiety among whites about the future. An advertizing executive says, �I think white people feel like they�re under siege right now � like it�s not okay to be white right now, especially if you�re a white male. ... People are stressed out about it. �We used to be in control! We�re losing
control�� Another says, "There�s a lot of fear and a lot of resentment."
It's hard to see why these feelings won't increase in the future.
A huge problem for white people is lack of intellectual and cultural confidence. Hsu quotes Christian (Stuff White People Like) Lander saying, "I get it: as a straight white male, I�m the worst thing on Earth." A professor comments that for his students "to be white is to be culturally broke. The classic thing white students say when
you ask them to talk about who they are is, �I don�t have a culture.� They might be privileged, they might be loaded socioeconomically, but they feel bankrupt when it comes to culture � They feel disadvantaged, and they feel marginalized."
This lack of cultural confidence is no accident. For nearly 100 years whites have been subjected to a culture of critique emanating from the most prestigious academic and media institutions. And, as Hsu points out, the most vibrant and influential aspect of American popular culture is hip-hop�a product of the African American
urban culture.
The only significant group of white people with any cultural confidence centers itself around country music, NASCAR, and the small town values of traditional white America. For this group of whites � and only this group � there is "a racial pride that dares not speak its name, and that defines itself through cultural cues instead�a
suspicion of intellectual elites and city dwellers, a preference for folksiness and plainness of speech (whether real or feigned), and the association of a working-class white minority with 'the real America.'�
This is what I term implicit whiteness � implicit because explicit assertions of white identity have been banned by the anti-white elites that dominate our politics and culture. It is a culture that, as Hsu notes, "cannot speak its name."
But that implies that the submerged white identity of the white working class and the lack of cultural confidence exhibited by the rest of white America are imposed from outside. Although there may well be characteristics of whites that facilitate this process, this suppression of white identity and interests is certainly not the natural
outcome of modernization or any other force internal to whites as a people. In my opinion, it is the result of the successful erection of a culture of critique in the West dominated by Jewish intellectual and political movements.
The result is that educated, intellectually insecure white people these days are far more likely to believe in the utopian future described by Hsu than in hard and cautious thinking about what the future might have in store for them.
It's worth dwelling a bit on the intellectual insecurity of the whites who mindlessly utter the mantras of multiculturalism that they have soaked up from the school system and from the media. Most people do not have much confidence in their intellectual ability and look to elite opinion to shape their beliefs. As I noted elsewhere,
A critical component of the success of the culture of critique is that it achieved control of the most prestigious and influential institutions of the West, and it became a consensus among the elites, Jewish and non-Jewish alike. Once this happened, it is not surprising that this culture became widely accepted among people of very
different levels of education and among people of different social classes.
Most people are quite insecure about their intellectual ability. But they know that the professors at Harvard, and the editorial page of the New York Times and the Washington Post, and even conservative commentators like Rush Limbaugh and Sean Hannity are all on page when it comes to racial and ethnic issues. This is a
formidable array, to the point that you almost have to be a crank to dissent from this consensus.
I think one of the greatest triumphs of the left has been to get people to believe that people who assert white identity and interests or who make unflattering portrayals of organized Jewish movements are morally degenerate, stupid, and perhaps psychiatrically disturbed. Obviously, all of these adjectives designate low status.
The reality is that the multicultural emperor has no clothes and, because of its support for racial Zionism and the racialism of ethnic minorities in America, it is massively hypocritical to boot. The New York Times, the academic left, and the faux conservatives that dominate elite discourse on race and ethnicity are intellectually
bankrupt and can only remain in power by ruthlessly suppressing or ignoring the scientific findings.
This is particularly a problem for college-educated whites. Like Fitzgerald's Tom Buchanan, such people have a strong need to feel that their ideas are respectable and part of the mainstream. But the respectable mainstream gives them absolutely nothing with which to validate themselves except perhaps the idea that the world
will be a better place when people like them no longer have power. Hsu quotes the pathetic Christian Lander: "�Like, I�m aware of all the horrible crimes that my demographic has done in the world. ... And there�s a bunch of white people who are desperate � desperate � to say, �You know what? My skin�s white, but I�m not one
of the white people who�s destroying the world.��
As a zombie leftist during the 1960s and 1970s, I know what that feeling of desperation is like � what it's like to be a self-hating white. We must get to the point where college-educated whites proudly and confidently say they are white and that they do not want to become a minority in America.
This reminds me of the recent docudrama Milk, which depicts the life of gay activist Harvey Milk. Milk is sure be nominated for an Oscar as Best Picture because it lovingly illustrates a triumph of the cultural left. But is has an important message that should resonate with the millions of whites who have been deprived of their
confidence and their culture: Be explicit. Just as Harvey Milk advocated being openly gay even in the face of dire consequences, whites need to tell their family and their friends that they have an identity as a white person and believe that whites have legitimate interests as white people. They must accept the consequences
when they are harassed, fired from their jobs, or put in prison for such beliefs. They must run for political office as openly pro-white.
Milk shows that homosexuals were fired from their jobs and arrested for congregating in public. Now it's the Southern Poverty Law Center and the rest of the leftist intellectual and political establishment that harasses and attempts to get people fired. But it's the same situation with the roles reversed. No revolution was ever
accomplished without some martyrs. The revolution that restores the legitimacy of white identity and the legitimacy of white interests will be no exception.
But it is a revolution that is absolutely necessary. The white majority is foolish indeed to entrust its future to a utopian hope that racial and ethnic identifications will disappear and that they won�t continue to influence public policy in ways that compromise the interests of whites.
It does not take an overactive imagination to see that coalitions of minority groups could compromise the interests of formerly dominant whites. We already see numerous examples in which coalitions of minority groups attempt to influence public policy, including immigration policy, against the interests of the whites. Placing
ourselves in a position of vulnerability would be extremely risky, given the deep sense of historical grievance fostered by many ethnic activists and organized ethnic lobbies.
This is especially the case with Jews. Jewish organisations have been unanimous in condemning Western societies, Western traditions, and Christianity, for past crimes against Jews. Similar sentiments are typical of a great many African Americans and Latinos, and especially among the ethnic activists from these groups. The
�God damn America� sermon by President Obama's pastor comes to mind as a recent notorious example.
The precedent of the early decades of the Soviet Union should give pause to anyone who believes that surrendering ethnic hegemony does not carry risks. The Bolshevik revolution had a pronounced ethnic angle: To a very great extent, Jews and other non-Russians ruled over the Russian people, with disastrous
consequences for the Russians and other ethnic groups that were not able to become part of the power structure. Jews formed a hostile elite within this power structure � as they will in the future white-minority America; Jews were �Stalin�s willing executioners.�
Two passages from my review of Yuri Slezkine's The Jewish Century seem particularly appropriate here. The first passage reminds me of the many American Jews who adopt a veneer of support for leftist versions of social justice and racial tolerance while nevertheless managing to support racial Zionism and the mass murder,
torture, and incarceration of the Palestinian people in one of the largest prison systems the world has ever seen. Such people may be very different when they become a hostile elite in a white-minority America.
Many of the commentators on Jewish Bolsheviks noted the �transformation� of Jews [after the Bolshevik Revolution]. In the words of [a] Jewish commentator, G. A. Landau, �cruelty, sadism, and violence had seemed alien to a nation so far removed from physical activity.� And another Jewish commentator, Ia. A. Bromberg, noted
that:
the formerly oppressed lover of liberty had turned into a tyrant of �unheard-of-despotic arbitrariness��. The convinced and unconditional opponent of the death penalty not just for political crimes but for the most heinous offenses, who could not, as it were, watch a chicken being killed, has been transformed outwardly into a
leather-clad person with a revolver and, in fact, lost all human likeness. ...
After the Revolution, ... there was active suppression of any remnants of the older order and their descendants. ... The mass murder of peasants and nationalists was combined with the systematic exclusion of the previously existing non-Jewish middle class. The wife of a Leningrad University professor noted, �in all the
institutions, only workers and Israelites are admitted; the life of the intelligentsia is very hard� (p. 243). Even at the end of the 1930s, prior to the Russification that accompanied World War II, �the Russian Federation�was still doing penance for its imperial past while also serving as an example of an ethnicity-free society� (p. 276).
While all other nationalities, including Jews, were allowed and encouraged to keep their ethnic identities, the revolution remained an anti-majoritarian movement.
The difference from the Soviet Union may well be that in white-minority America it will not be workers and Israelites who are favored, but non-whites and Israelites. Whites may dream that they are entering the post-racial utopia imagined by their erstwhile intellectual superiors. But it is quite possible that they are entering into a
racial dystopia of unimaginable cruelty in which whites will be systematically excluded in favor of the new elites recruited from the soon-to-be majority. It's happened before.
Kevin MacDonald is a professor of psychology at California State University�Long Beach.
Permanent URL with hyperlinks:
http://www.theoccidentalobserver.net/articles/MacDonald-Hsu.html
-----------
Should Christians Support Israeli Terrorism in Gaza?
A timely discussion between Rev. Ted Pike and Dr. David Duke, one especially important for the Christians in our audience
http://www.davidduke.com/mp3/dukeradio090122DukeandPikeonGaza.mp3
In this vital discussion, Rev. Pike and Dr. Duke explore the Pro-Israel attitude of some Christian evangelical organizations, and why their position not only goes directly against Christian morality and decency, but actually is directly opposite of that expressed by Christian Scriptures. Today, Many Christians are instructed that Jews
and today�s Israel has a special covenant� with God. In fact, the New Testament in the clearest of language states that the Jews �continued not in my covenant, and I considered them not, saith the Lord.� Here�s the quote that Christians aren�t supposed to notice.:
8:10 Not according to the covenant that I made with their fathers, in the day when I took them by the hand out of the land of Egypt; because they continued not in my covenant, and I regarded them not, saith the Lord. (Hebrews 8:10)
They also don�t seem to notice that a 2000 year old Judaic war against Christianity that has been waged since time of Jesus Christ and still goes on today with the most powerful Jewish organizations attempting to destroy European and American traditions, that has even become a war on our Christmas traditions.
Dr. Duke and Ted Pike also speak about how over a hundred thousand Christian Palestinians have suffered with their families from anti-Christian Israel! Christian support of Israel has resulted in the very birthplace of Jesus Christ, go from 90 percent Palestinian Christians to 35 percent today because of Israeli terror and
occupation. They ask, �How could any Christian in good conscience support the anti-Christian state of Israel, bombing the homes, killing and maiming, torturing and oppressing fellow Christian men, women and children?�
This is a vital show for every Christian reader and listener of DavidDuke.com. Next time, you hear someone say, �God tells us that we must support Israel� you will have the clear Christian answer that just the opposite is true!
For documentation on this be sure to read some of the well-footnoted, sample chapters of Jewish Supremacism and My Awakening.
Source :
http://www.davidduke.com/general/should-christians-support-israeli-terroris…
-------------------------------------
You or someone using your email adress is currently subscribed to the Lawrence Auster
Newletter. If you wish to unsubscribe from our mailing list, please let us know by calling to 1 212 865 1284
Thanks,
Lawrence Auster,
238 W 101 St Apt. 3B
New York, NY 10025
Contact: lawrence.auster(a)att.net
-------------------------------------
1
0
Author: ctian
Date: Wed Nov 26 19:33:04 2008
New Revision: 19
Log:
trivial read-macro fixes for lispworks 5, let me do this before lost the access please
Modified:
trunk/code/atn-parser/clifs/inference-system-classes.lisp
trunk/code/atn-parser/clifs/inference-units.lisp
Modified: trunk/code/atn-parser/clifs/inference-system-classes.lisp
==============================================================================
--- trunk/code/atn-parser/clifs/inference-system-classes.lisp (original)
+++ trunk/code/atn-parser/clifs/inference-system-classes.lisp Wed Nov 26 19:33:04 2008
@@ -101,11 +101,11 @@
(setf (getf (system-plist system) indicator) value))
;; wg. CL-Konformitaet
-(defmethod documentation ((x inference-system) #-(or CMU LispWorks4 sbcl openmcl) &optional type)
+(defmethod documentation ((x inference-system) #-(or CMU LispWorks sbcl openmcl) &optional type)
(declare (ignore type))
(slot-value x 'doc))
-(defmethod (setf documentation) (doc (x inference-system) #-(or CMU LispWorks4 sbcl openmcl) &optional type)
+(defmethod (setf documentation) (doc (x inference-system) #-(or CMU LispWorks sbcl openmcl) &optional type)
(declare (ignore type))
(setf (slot-value x 'doc) doc))
Modified: trunk/code/atn-parser/clifs/inference-units.lisp
==============================================================================
--- trunk/code/atn-parser/clifs/inference-units.lisp (original)
+++ trunk/code/atn-parser/clifs/inference-units.lisp Wed Nov 26 19:33:04 2008
@@ -32,11 +32,11 @@
(documentation :accessor rule-documentation
:initarg :documentation)))
-(defmethod documentation ((x rule) #-(or CMU LispWorks4 sbcl openmcl) &optional doc-type)
+(defmethod documentation ((x rule) #-(or CMU LispWorks sbcl openmcl) &optional doc-type)
(declare (ignore doc-type))
(slot-value x 'documentation))
-(defmethod (setf documentation) (doc-string (x rule) #-(or CMU LispWorks4 sbcl openmcl) &optional doc-type)
+(defmethod (setf documentation) (doc-string (x rule) #-(or CMU LispWorks sbcl openmcl) &optional doc-type)
(declare (ignore doc-type))
(setf (slot-value x 'documentation) doc-string))
1
0
[cl-xml-cvs] r18 - in trunk: code code/base code/xparser code/xquerydatamodel documentation
by Chun Tian 26 Nov '08
by Chun Tian 26 Nov '08
26 Nov '08
Author: ctian
Date: Wed Nov 26 19:29:33 2008
New Revision: 18
Log:
Clean DS_Store files from repository ^_^
Removed:
trunk/code/.DS_Store
trunk/code/base/.DS_Store
trunk/code/xparser/.DS_Store
trunk/code/xquerydatamodel/.DS_Store
trunk/documentation/.DS_Store
1
0
Author: janderson
Date: Mon May 28 12:09:07 2007
New Revision: 17
Modified:
trunk/code/xparser/xml-stream-coding.lisp
Log:
several changes for runtime compatibility; corrections to coding functions; eol-> nl.
Modified: trunk/code/xparser/xml-stream-coding.lisp
==============================================================================
--- trunk/code/xparser/xml-stream-coding.lisp (original)
+++ trunk/code/xparser/xml-stream-coding.lisp Mon May 28 12:09:07 2007
@@ -1 +1,800 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-
#|
<DOCUMENTATION>
<DESCRIPTION>
<P>
this implementes stream readers which perform decoding/encoding in the case
of a binary stream. the correct decoder is selected by first examining the type of
input element which the stream will offer and the, in the case of binary streams,
by examining the initial byte sequence.
no attempt is made to distinguish the encoder based on the stream's class.
the detection methods return a reader function together with its argument, the
detected decoding and, where it is necessary to read an initial byte sequence, that
sequence as a string to be reread.
</P>
</DESCRIPTION>
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
href='file://xml/sysdcl.lisp' />
<CHRONOLOGY>
<DELTA DATE='20010328' AUTHOR='JAA'>
adapted from version 0.4*</DELTA>
<DELTA DATE='20010605' AUTHOR='MS'>
LispWorks conformance</DELTA>
<DELTA DATE='20010621'>added a method to encode UTF-8 for character streams</DELTA>
<DELTA DATE='20010907'>
<ul><li><code>*xml-verbose*</code></li>
<li>fixed incorrect decoding for re-read sequence by recognized UTF-1612/21 BOM</li></ul></DELTA>
<DELTA DATE='20010914'>provisional us-ascii encoding method</DELTA>
<DELTA DATE='20020118'>corrections to encoding-stream-writer for non-mcl;
fixed autodetect code to recognize allegro :EOF; fixed us-ascii stream-reader for same.</DELTA>
<DELTA DATE='20030602'>provisioins for allegro simple-streams with character element-type</DELTA>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "XML-PARSER")
#+(or ALLEGRO LispWorks CormanLisp CMU sbcl)
(defMacro lsh (x y) `(ash ,x ,y))
#+(and allegro allegro-version>= (not (version>= 6 0)))
(progn
;; acl 5.0 versions
(defMethod stream-reader ((stream excl:fundamental-character-input-stream))
(let ((methods (compute-applicable-methods #'excl:stream-read-char (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'(lambda (arg)
(setf arg (excl:stream-read-char arg))
(unless (eq arg :eof) arg)))
stream)))
(defMethod stream-reader ((stream excl:fundamental-binary-input-stream))
(let ((methods (compute-applicable-methods #'excl:stream-read-byte (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'(lambda (arg)
(setf arg (excl:stream-read-byte arg))
(unless (eq arg :eof) arg)))
stream)))
(defMethod stream-writer ((stream excl:fundamental-character-output-stream))
(let ((methods (compute-applicable-methods #'excl:stream-write-char (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'excl:stream-write-char)
stream)))
(defMethod stream-writer ((stream excl:fundamental-binary-output-stream))
(let ((methods (compute-applicable-methods #'excl:stream-write-byte (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'excl:stream-write-byte)
stream)))
;; end acl5.0 versions
)
#+(and allegro allegro-version>= (version>= 6 0))
(progn
;; originally allegro 6.0 version
(defmethod stream-reader ((stream excl:fundamental-stream))
(values #'(lambda (stream) (read-byte stream nil nil))
stream))
(defmethod stream-writer ((stream excl:fundamental-stream))
(values #'(lambda (stream byte) (write-byte byte stream))
stream))
;; originally allegro 6.1 version; Bob Rogers <rogers(a)rgrjr.dyndns.org> remarked, that
;; they're present in 6.0 as well
(defmethod stream-reader ((stream excl:simple-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream) (read-char stream nil nil))
#'(lambda (stream) (read-byte stream nil nil)))
stream))
(defMethod stream-writer ((stream excl:simple-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char) (write-char char stream))
#'(lambda (stream byte) (write-byte byte stream)))
stream))
)
#+LispWorks
(defMethod stream-reader ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream) (read-char stream nil nil))
#'(lambda (stream) (read-byte stream nil nil)))
stream))
#+LispWorks
(defMethod stream-writer ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char) (write-char char stream))
#'(lambda (stream byte) (write-byte byte stream)))
stream))
#+CormanLisp
(defMethod stream-reader ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+CormanLisp
(defMethod stream-writer ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
#+(and mcl (not digitool))
(defMethod stream-reader ((stream fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+(and mcl (not digitool))
(defMethod stream-writer ((stream fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
#+CMU
(defmethod stream-element-type ((stream stream))
; (cl::fd-stream-element-type stream)
'(unsigned-byte 8))
#+CMU
(defMethod stream-reader ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+CMU
(defMethod stream-writer ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
#+sbcl
(defmethod stream-element-type ((stream stream))
; (cl::fd-stream-element-type stream)
'(unsigned-byte 8))
#+sbcl
(defMethod stream-reader ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+sbcl
(defMethod stream-writer ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
;; adapted from cl-http:mcl;server;tcp-ot-stream for the strictly binary case
;; the first case comes into play without cl-http. connections are made with a simple tcp stream
;; the second case takes into account, that chunking decoding extends the generic function
#+(and mcl mactcp-compatibility)
(defMethod stream-reader ((stream ccl::binary-tcp-stream))
(values #'ccl::io-buffer-read-byte (ccl::stream-io-buffer stream)))
#+(and MCL CL-HTTP)
(defmethod stream-reader ((stream ccl::modal-ascii-or-binary-tcp-stream-mixin))
(values (case (ccl::input-mode stream)
(:ascii #'stream-tyi)
((:binary nil)
(let ((method-combination (ccl::generic-function-method-combination #'ccl::stream-read-byte))
(methods (compute-applicable-methods #'ccl::stream-read-byte (list stream))))
(ccl::compute-effective-method-function #'ccl::stream-read-byte
method-combination
methods))))
stream))
#+(and mcl mactcp-compatibility)
(defmethod stream-writer ((stream ccl::binary-tcp-stream))
(flet ((io-buffer-tyo-byte (io-buffer byte)
;; ? not sure that continuability is a good idea, but
(unless (typep io-buffer 'ccl::io-buffer)
(setq io-buffer (require-type io-buffer 'ccl::io-buffer)))
(if (characterp byte) (setf byte (char-code byte)))
(ccl::%io-buffer-write-byte io-buffer byte)))
(values #'io-buffer-tyo-byte (ccl::stream-io-buffer stream))))
#+(and mcl mactcp-compatibility)
(defMethod stream-element-type ((stream ccl::binary-tcp-stream))
;; mcl 4.2 yielded BASE-CHARACTER for this class and produced a character reader ...?
'unsigned-byte)
;; determine whether the stream supports binary operations
(defGeneric is-binary-stream (stream)
#-allegro
(:method ((stream stream)) (subtypep (stream-element-type stream) 'unsigned-byte))
;; allegro 6 "simple streams" can always do the byte operations
#+allegro
(:method ((stream string-stream)) nil)
#+allegro
(:method ((stream stream))
#+(and allegro-version>= (version>= 6 0)) t
#+(and allegro-version>= (not (version>= 6 0))) (subtypep (stream-element-type stream) 'unsigned-byte)
))
(defGeneric decoding-stream-reader (stream encoding)
(:method ((stream stream) (encoding null))
(decoding-stream-reader stream (stream-element-type stream)))
(:method ((stream stream) (type cons))
(decoding-stream-reader stream (first type)))
(:method ((stream stream) (encoding string) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(decoding-stream-reader stream canonical-encoding))
(t
(warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding))))
(:method ((stream stream) (encoding symbol) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(decoding-stream-reader stream canonical-encoding))
((subtypep encoding 'integer)
(decoding-stream-reader stream :autodetect))
((subtypep encoding 'character)
(decoding-stream-reader stream *default-character-encoding*))
(t
(warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding)))))
(defGeneric encoding-stream-writer (stream encoding)
(:method ((stream t) (encoding t))
(warn "no decoding defined for operation on stream: ~s: ~s." encoding stream)
(values nil nil))
(:method ((stream stream) (encoding null) &aux (type (stream-element-type stream)))
(unless type
(warn "assuming element type character for stream: ~s." stream)
(setf type 'character))
(encoding-stream-writer stream type))
(:method ((stream stream) (type cons))
(encoding-stream-writer stream (first type)))
(:method ((stream stream) (encoding string) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(encoding-stream-writer stream canonical-encoding))
(t
(warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding))))
(:method ((stream stream) (encoding symbol) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(encoding-stream-writer stream canonical-encoding))
((subtypep encoding 'integer)
(encoding-stream-writer stream *default-binary-encoding*))
((subtypep encoding 'character)
(encoding-stream-writer stream *default-character-encoding*))
(t
(warn "no encoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding)))))
(defMacro funcall-function.arg (function.arg &rest args)
`(funcall (first ,function.arg) (rest ,function.arg) ,@args))
(defun change-stream-decoding (new-encoding)
(etypecase new-encoding
(keyword t)
((or string (and symbol (not null)))
(setf new-encoding (intern (string-upcase new-encoding) "KEYWORD"))))
(if (or (eq new-encoding *input-encoding*)
(and (eq new-encoding :utf-16)
(member *input-encoding* '(:utf-16-12 :utf-16-21))))
(values *input-encoding* nil)
(multiple-value-bind (function arg detected-encoding to-reread)
(decoding-stream-reader *input-source* new-encoding)
(unless (and (eq detected-encoding new-encoding)
(null to-reread))
(error "can't change encoding: ~s: ~s -> ~s = ~s/~s."
*input-source*
*input-encoding* new-encoding detected-encoding to-reread))
(unless function (error "no reader for encoding: ~s." new-encoding))
(setf *input-reader* function
*input-reader-arg* arg
*input-encoding* new-encoding)
;; return the new encoding
(values new-encoding t))))
;;
;;
;; UTF-8 is computed
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-8)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-reader stream)
(values #'(lambda (function.arg &aux byte1)
(block read-utf-8-datum
(flet ((read-byte-code (&aux byte)
(setf byte (funcall-function.arg function.arg))
(if (integerp byte) byte
(return-from read-utf-8-datum nil))))
(declare (type fixnum byte1)
(ftype (function () fixnum) read-byte-code)
(optimize (speed 3) (safety 0)))
(setf byte1 (read-byte-code))
(cond ((= 0 (logand #x80 byte1))
byte1)
((= #xc0 (logand #xe0 byte1))
(logior (lsh (logand byte1 #x1f) 6)
(logand (read-byte-code) #x3f)))
((= #xe0 (logand #xf0 byte1))
(logior (logior (lsh (logand byte1 #x0f) 12)
(lsh (logand (read-byte-code) #x3f) 6))
(logand (read-byte-code) #x3f)))
((= #xf0 (logand #xf8 byte1))
(let ((byte2 (read-byte-code))
(byte3 (read-byte-code))
(byte4 (read-byte-code)))
(xml-error "unsupported unicode datum: ~s."
(list byte1 byte2 byte3 byte4))))
(t
(xml-error "illegal UTF-8 data: x~2,'0x." byte1))))))
(cons function arg)
:UTF-8)))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-8)))
(if (is-binary-stream stream)
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg char &aux (code (char-code char)))
(cond ((<= code 255)
(funcall-function.arg function.arg code))
((<= code #x03ff)
(funcall-function.arg function.arg (logior #b11000000 (lsh code -6)))
(funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
((<= code #xffff)
(funcall-function.arg function.arg (logior #b11100000 (lsh code -12)))
(funcall-function.arg function.arg (logior #b10000000 (logand (lsh code -6) #b00111111)))
(funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
(t
(xml-error "unsupported unicode datum: ~s." code))))
(cons function arg)))
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg char &aux (code (char-code char)))
(cond ((<= code 255)
(funcall-function.arg function.arg char))
(t
(let ((string (format nil "&#~d" code)))
(dotimes (x (length string))
(funcall-function.arg function.arg (char string x)))))))
(cons function arg)))))
;;
;;
;; ISO-8859-1 is direct
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :ISO-8859-1)))
(multiple-value-bind (function arg)
(stream-reader stream)
(if (is-binary-stream stream)
#-(or MCL LispWorks)
(multiple-value-bind (reader arg)
(stream-reader stream)
(values #'(lambda (function.arg &aux byte)
(setf byte (funcall-function.arg function.arg))
(when (integerp byte) byte))
(cons reader arg)
encoding))
#+(or MCL LispWorks)
(values function arg encoding)
;; character streams must be mapped back to binary
(values #'(lambda (function.arg &aux char)
(setf char (funcall-function.arg function.arg))
(when (characterp char)
;; hardcore tracing
;; (write-char char *trace-output*)
(char-code char)))
(cons function arg)
encoding))))
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :US-ASCII)))
(multiple-value-bind (function arg)
(stream-reader stream)
(if (is-binary-stream stream)
#-(or MCL LispWorks)
(multiple-value-bind (reader arg)
(stream-reader stream)
(values #'(lambda (function.arg &aux byte)
(setf byte (funcall-function.arg function.arg))
(when (integerp byte) byte))
(cons reader arg)
encoding))
#+(or MCL LispWorks)
(values function arg encoding)
;; character streams must be mapped back to binary
(values #'(lambda (function.arg &aux char)
(setf char (funcall-function.arg function.arg))
(when (characterp char)
(char-code char)))
(cons function arg)
encoding))))
#+digitool ;; fix eol
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :ISO-8859-1)))
(multiple-value-bind (function arg)
(stream-writer stream)
(if (is-binary-stream stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#x0d
(char-code char))))
(cons function arg)
encoding)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#.(code-char #x0d)
char)))
(cons function arg)
encoding))))
#-digitool
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :ISO-8859-1)))
(if (is-binary-stream stream)
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg (char-code char)))
(cons function arg)
encoding))
(multiple-value-bind (function arg)
(stream-writer stream)
(values function arg encoding))))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :US-ASCII)))
(multiple-value-bind (function arg)
(stream-writer stream)
#+digitool
(if (is-binary-stream stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#x0d
(char-code char))))
(cons function arg)
encoding)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#.(code-char #x0d)
char)))
(cons function arg)
encoding))
#-digitool
(if (is-binary-stream stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg (char-code char)))
(cons function arg)
encoding)
(values function arg encoding))))
;;
;;
;; UTF-16 distinguishes encoding order:
;; UTF-16LE is UTF16 in "little-endian" byte order. (order mark is 0xFF 0xFE)
;; UTF-16BE is UTF16 in "big-endian" byte order. (order mark is 0xFE 0xFF)
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-16)))
(decoding-stream-reader stream *default-utf-16-encoding*))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-16)))
(encoding-stream-writer stream *default-utf-16-encoding*))
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-16-12)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-reader stream)
(values #'(lambda (function.arg)
(declare (ftype (function () fixnum) read-byte-code)
(optimize (speed 3) (safety 0)))
(block read-utf-16-datum
(flet ((read-byte-code (&aux byte)
(setf byte (funcall-function.arg function.arg))
(if (integerp byte) byte
(return-from read-utf-16-datum nil))))
(+ (lsh (read-byte-code) 8) (read-byte-code)))))
(cons function arg)
encoding)))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-16-12)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg datum)
(setf datum (char-code datum))
(funcall-function.arg function.arg (logand #xff (lsh datum -8)))
(funcall-function.arg function.arg (logand #xff datum)))
(cons function arg))))
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-16-21)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-reader stream)
(values #'(lambda (function.arg)
(declare (ftype (function () fixnum) read-byte-code)
(optimize (speed 3) (safety 0)))
(block read-utf-16-datum
(flet ((read-byte-code (&aux byte)
(setf byte (funcall-function.arg function.arg))
(if (integerp byte) byte
(return-from read-utf-16-datum nil))))
(+ (read-byte-code) (lsh (read-byte-code) 8)))))
(cons function arg)
encoding)))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-16-21)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg datum)
(setf datum (char-code datum))
(funcall-function.arg function.arg (logand #xff datum))
(funcall-function.arg function.arg (logand #xff (lsh datum -8))))
(cons function arg))))
;;
;;
;; detect encoding by reading the initial content. works for binary streams only
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :autodetect)) &aux byte0 byte1 to-reread)
"see PR-xml Appendix F"
(multiple-value-bind (reader arg) (stream-reader stream)
(flet ((next-byte (&aux (byte (funcall reader arg)))
(typecase byte
(fixnum byte)
(t nil))))
(case (setf byte0 (next-byte))
(#x00 (case (next-byte)
(#x00 (case (next-byte)
(#x3c (if (= (next-byte) #x00)
(setf encoding :UCS-4-2143 to-reread "<")
(error "markup stream corrupt: ~s." stream)))
(#x00 (if (= (next-byte) #x3c)
(setf encoding :UCS-4-1234 to-reread "<")
(error "markup stream corrupt: ~s." stream)))
(#xFE (if (= (next-byte) #xFF)
(setf encoding :UCS-4-1234 to-reread nil)
(error "markup stream corrupt: ~s." stream)))
(#xFF (if (= (next-byte) #xFE)
(setf encoding :UCS-4-2143 to-reread nil)
(error "markup stream corrupt: ~s." stream)))
(t (error "markup stream corrupt: ~s." stream))))
(#x3c (if (= (setf byte1 (next-byte)) #x00)
(case (setf byte1 (next-byte))
(#x00 (setf encoding :UCS-4-3412 to-reread "<"))
(#x3f
(when *xml-verbose*
(warn "assuming UTF-16-21 encoding for stream: ~s." stream))
(setf encoding :UTF-16-21 to-reread "<?"))
(t (|EC: Byte Order Mark| :data (list #x00 #x3c #x00 byte1))))
(|EC: Byte Order Mark| :data (list #x00 #x3c byte1))))
(t
(error "markup stream corrupt: ~s." stream))))
(#x3c (case (setf byte1 (next-byte))
(#x00 (case (setf byte1 (next-byte))
(#x3f (case (setf byte1 (next-byte))
(#x00
(when *xml-verbose*
(warn "assuming UTF-16-12 encoding for stream: ~s." stream))
(setf encoding :UTF-16-12 to-reread "<?"))
(t
(|EC: Byte Order Mark| :data (list #x3c #x00 #x3f byte1)))))
(#x00 (if (= (next-byte) #x00)
(setf encoding :UCS-4-4321 to-reread "<")
(|EC: Byte Order Mark| :data (list #x3c #x00 #x00 byte1))))
(t
(|EC: Byte Order Mark| :data (list #x3c #x00 byte1)))))
(#x3f (setf encoding *default-binary-encoding* to-reread "<?"))
(t
(unless (or (xml-initial-namechar? byte1) (= byte1 #.(char-code #\!)))
(when *xml-verbose*
(warn "assuming UTF-8 encoding for stream: ~s." stream)))
(setf encoding *default-binary-encoding* to-reread (list byte0 byte1)))))
(#xEF (case (setf byte1 (next-byte))
(#xBB (if (= (setf byte1 (next-byte)) #xBF)
(setf encoding :UTF-8 to-reread nil)
(|EC: Byte Order Mark| :data (list #xEF #xBB byte1))))
(t
(|EC: Byte Order Mark| :data (list #xEF byte1)))))
(#xff
(if (= (setf byte1 (next-byte)) #xfe)
(let ((byte2 (next-byte)) (byte3 (next-byte)))
(if (and (= byte2 0) (= byte3 0))
(setf encoding :UCS4-4321 to-reread nil)
(setf encoding :UTF-16-21 to-reread (list (+ byte2 (lsh byte3 8))))))
(|EC: Byte Order Mark| :data (list #xff byte1))))
(#xfe
(if (= (setf byte1 (next-byte)) #xff)
(let ((byte2 (next-byte)) (byte3 (next-byte)))
(if (and (= byte2 0) (= byte3 0))
(setf encoding :UCS4-3412 to-reread nil)
(setf encoding :UTF-16-12 to-reread (list (+ (lsh byte2 8) byte3)))))
(|EC: Byte Order Mark| :data (list #xfe byte1))))
((nil) ;; no data in stream
(setf encoding :UTF-8 to-reread nil))
(t
(when *xml-verbose*
(warn "assuming UTF-8 encoding for stream: ~s." stream))
(setf encoding :UTF-8 to-reread (list byte0))))
(multiple-value-bind (reader arg encoding) (decoding-stream-reader stream encoding)
(values reader arg encoding to-reread)))))
#|
(defun utf-8-decoding (byte1 &optional (byte2 0) (byte3 0) (byte4 0))
(cond ((= 0 (logand #x80 byte1))
byte1)
((= #xc0 (logand #xe0 byte1))
(logior (lsh (logand byte1 #x1f) 6) (logand byte2 #x3f)))
((= #xe0 (logand #xf0 byte1))
(logior (logior (lsh (logand byte1 #x0f) 12) (lsh (logand byte2 #x3f) 6)) (logand byte3 #x3f)))
((= #xf0 (logand #xf8 byte1))
(xml-error "unsupported unicode datum: ~s."
(list byte1 byte2 byte3 byte4)))
(t
(xml-error "illegal UTF-8 data: #x~2,'0x." byte1))))
(xml-namechar? (utf-8-decoding 194 183 0 0))
(xml-space? (utf-8-decoding 239 187 191))
(apply #'utf-8-decoding (map 'list #'char-code "༤"))
(defun utf-8-decodingXstring (string)
(handler-case
(apply #'utf-8-decoding (map 'list #'char-code string))
(error (condition) (format nil "~s(~{~2,'0x~}) -> ~a"
string (map 'list #'char-code string)
condition))))
(format nil "~{~8,'0x~^~%~}" (mapcar #'utf-8-decodingXstring
'("" "氏" "" "�" "�")))
from the 3.1 unicode report
Table 3.1.
UTF-8 Bit Distribution
Scalar Value UTF-16 1st Byte 2nd Byte 3rd Byte 4th Byte
00000000 0xxxxxxx 00000000 0xxxxxxx 0xxxxxxx
00000yyy yyxxxxxx 00000yyy yyxxxxxx 110yyyyy 10xxxxxx
zzzzyyyy yyxxxxxx zzzzyyyy yyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx
000uuuuu zzzzyyyy 110110ww wwzzzzyy 11110uuu 10uuzzzz 10yyyyyy 10xxxxxx
yyxxxxxx 110111yy yyxxxxxx
Where uuuuu = wwww + 1 (to account for addition of 1000016 as in Section 3.7, Surrogates).
|#
:EOF
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-
+
+
+#|
+<DOCUMENTATION>
+ <DESCRIPTION>
+ <P>
+ this implementes stream readers which perform decoding/encoding in the case
+ of a binary stream. the correct decoder is selected by first examining the type of
+ input element which the stream will offer and the, in the case of binary streams,
+ by examining the initial byte sequence.
+ no attempt is made to distinguish the encoder based on the stream's class.
+ the detection methods return a reader function together with its argument, the
+ detected decoding and, where it is necessary to read an initial byte sequence, that
+ sequence as a string to be reread.
+ </P>
+ </DESCRIPTION>
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+ href='file://xml/sysdcl.lisp' />
+ <CHRONOLOGY>
+ <DELTA DATE='20010328' AUTHOR='JAA'>
+ adapted from version 0.4*</DELTA>
+ <DELTA DATE='20010605' AUTHOR='MS'>
+ LispWorks conformance</DELTA>
+ <DELTA DATE='20010621'>added a method to encode UTF-8 for character streams</DELTA>
+ <DELTA DATE='20010907'>
+ <ul><li><code>*xml-verbose*</code></li>
+ <li>fixed incorrect decoding for re-read sequence by recognized UTF-1612/21 BOM</li></ul></DELTA>
+ <DELTA DATE='20010914'>provisional us-ascii encoding method</DELTA>
+ <DELTA DATE='20020118'>corrections to encoding-stream-writer for non-mcl;
+ fixed autodetect code to recognize allegro :EOF; fixed us-ascii stream-reader for same.</DELTA>
+ <DELTA DATE='20030602'>provisions for allegro simple-streams with character element-type</DELTA>
+ <DELTA DATE='20030602'>scl</DELTA>
+ <DELTA DATE='20040123'>correction to utf-16-{21,12} order discovered from initial declaration
+ bytes rather than from BOM.</DELTA>
+ <DELTA DATE='20060116'>lsh ccl-specific</DELTA>
+ <DELTA DATE='20070415'>corrected utf-8 encoding bounds.</DELTA>
+ </CHRONOLOGY>
+ </DOCUMENTATION>
+|#
+
+(in-package "XML-PARSER")
+
+(defvar *illegal-utf-data-condition* nil)
+
+#+(or ALLEGRO LispWorks CormanLisp CMU sbcl scl)
+(defMacro lsh (x y) `(ash ,x ,y))
+
+#+ccl
+(unless (eq (symbol-package 'lsh) (find-package :ccl))
+ (defmacro lsh (x y) `(ccl:lsh ,x ,y)))
+
+#+(and allegro allegro-version>= (not (version>= 6 0)))
+(progn
+ ;; acl 5.0 versions
+
+ (defMethod stream-reader ((stream excl:fundamental-character-input-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-read-char (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'(lambda (arg)
+ (setf arg (excl:stream-read-char arg))
+ (unless (eq arg :eof) arg)))
+ stream)))
+
+ (defMethod stream-reader ((stream excl:fundamental-binary-input-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-read-byte (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'(lambda (arg)
+ (setf arg (excl:stream-read-byte arg))
+ (unless (eq arg :eof) arg)))
+ stream)))
+
+ (defMethod stream-writer ((stream excl:fundamental-character-output-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-write-char (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'excl:stream-write-char)
+ stream)))
+
+ (defMethod stream-writer ((stream excl:fundamental-binary-output-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-write-byte (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'excl:stream-write-byte)
+ stream)))
+ ;; end acl5.0 versions
+ )
+
+#+(and allegro allegro-version>= (version>= 6 0))
+(progn
+ ;; originally allegro 6.0 version
+ (defmethod stream-reader ((stream excl:fundamental-stream))
+ (values #'(lambda (stream) (read-byte stream nil nil))
+ stream))
+ (defmethod stream-writer ((stream excl:fundamental-stream))
+ (values #'(lambda (stream byte) (write-byte byte stream))
+ stream))
+
+
+ ;; originally allegro 6.1 version; Bob Rogers <rogers(a)rgrjr.dyndns.org> remarked, that
+ ;; they're present in 6.0 as well
+ (defmethod stream-reader ((stream excl:simple-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream) (read-char stream nil nil))
+ #'(lambda (stream) (read-byte stream nil nil)))
+ stream))
+ (defMethod stream-writer ((stream excl:simple-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char) (write-char char stream))
+ #'(lambda (stream byte) (write-byte byte stream)))
+ stream))
+ )
+
+#+LispWorks
+(defMethod stream-reader ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream) (read-char stream nil nil))
+ #'(lambda (stream) (read-byte stream nil nil)))
+ stream))
+#+LispWorks
+(defMethod stream-writer ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char) (write-char char stream))
+ #'(lambda (stream byte) (write-byte byte stream)))
+ stream))
+
+#+CormanLisp
+(defMethod stream-reader ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+CormanLisp
+(defMethod stream-writer ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+(and mcl (not digitool))
+(defMethod stream-reader ((stream fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+
+#+(and mcl (not digitool))
+(defMethod stream-writer ((stream fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+CMU
+(defmethod stream-element-type ((stream stream))
+ ; (cl::fd-stream-element-type stream)
+ '(unsigned-byte 8))
+
+#+CMU
+(defMethod stream-reader ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+CMU
+(defMethod stream-writer ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+scl
+(defMethod stream-reader ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+scl
+(defMethod stream-writer ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+
+#+sbcl
+(defmethod stream-element-type ((stream stream))
+ ; (cl::fd-stream-element-type stream)
+ '(unsigned-byte 8))
+
+#+sbcl
+(defMethod stream-reader ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+sbcl
+(defMethod stream-writer ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+
+
+;; adapted from cl-http:mcl;server;tcp-ot-stream for the strictly binary case
+;; the first case comes into play without cl-http. connections are made with a simple tcp stream
+;; the second case takes into account, that chunking decoding extends the generic function
+#+(and mcl mactcp-compatibility)
+(defMethod stream-reader ((stream ccl::binary-tcp-stream))
+ (values #'ccl::io-buffer-read-byte (ccl::stream-io-buffer stream)))
+
+#+(and MCL CL-HTTP)
+(defmethod stream-reader ((stream ccl::modal-ascii-or-binary-tcp-stream-mixin))
+ (values (case (ccl::input-mode stream)
+ (:ascii #'stream-tyi)
+ ((:binary nil)
+ (let ((method-combination (ccl::generic-function-method-combination #'ccl::stream-read-byte))
+ (methods (compute-applicable-methods #'ccl::stream-read-byte (list stream))))
+ (ccl::compute-effective-method-function #'ccl::stream-read-byte
+ method-combination
+ methods))))
+ stream))
+
+#+(and mcl mactcp-compatibility)
+(defmethod stream-writer ((stream ccl::binary-tcp-stream))
+ (flet ((io-buffer-tyo-byte (io-buffer byte)
+ ;; ? not sure that continuability is a good idea, but
+ (unless (typep io-buffer 'ccl::io-buffer)
+ (setq io-buffer (ccl:require-type io-buffer 'ccl::io-buffer)))
+ (if (characterp byte) (setf byte (char-code byte)))
+ (ccl::%io-buffer-write-byte io-buffer byte)))
+ (values #'io-buffer-tyo-byte (ccl::stream-io-buffer stream))))
+
+
+#+(and mcl mactcp-compatibility)
+(defMethod stream-element-type ((stream ccl::binary-tcp-stream))
+ ;; mcl 4.2 yielded BASE-CHARACTER for this class and produced a character reader ...?
+ 'unsigned-byte)
+
+;; determine whether the stream supports binary operations
+
+(defGeneric is-binary-stream (stream)
+ #-allegro
+ (:method ((stream stream)) (subtypep (stream-element-type stream) 'unsigned-byte))
+ ;; allegro 6 "simple streams" can always do the byte operations
+ #+allegro
+ (:method ((stream string-stream)) nil)
+ #+allegro
+ (:method ((stream stream))
+ #+(and allegro-version>= (version>= 6 0)) t
+ #+(and allegro-version>= (not (version>= 6 0))) (subtypep (stream-element-type stream) 'unsigned-byte)
+ ))
+
+(defGeneric decoding-stream-reader (stream encoding)
+ (:method ((stream stream) (encoding null))
+ (decoding-stream-reader stream (stream-element-type stream)))
+ (:method ((stream stream) (type cons))
+ (decoding-stream-reader stream (first type)))
+ (:method ((stream stream) (encoding string) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (decoding-stream-reader stream canonical-encoding))
+ (t
+ (warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding))))
+ (:method ((stream stream) (encoding symbol) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (decoding-stream-reader stream canonical-encoding))
+ ((subtypep encoding 'integer)
+ (decoding-stream-reader stream :autodetect))
+ ((subtypep encoding 'character)
+ (decoding-stream-reader stream *default-character-encoding*))
+ (t
+ (warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding)))))
+
+(defGeneric encoding-stream-writer (stream encoding)
+ (:method ((stream t) (encoding t))
+ (warn "no decoding defined for operation on stream: ~s: ~s." encoding stream)
+ (values nil nil))
+ (:method ((stream stream) (encoding null) &aux (type (stream-element-type stream)))
+ (unless type
+ (warn "assuming element type character for stream: ~s." stream)
+ (setf type 'character))
+ (encoding-stream-writer stream type))
+ (:method ((stream stream) (type cons))
+ (encoding-stream-writer stream (first type)))
+ (:method ((stream stream) (encoding string) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (encoding-stream-writer stream canonical-encoding))
+ (t
+ (warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding))))
+ (:method ((stream stream) (encoding symbol) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (encoding-stream-writer stream canonical-encoding))
+ ((subtypep encoding 'integer)
+ (encoding-stream-writer stream *default-binary-encoding*))
+ ((subtypep encoding 'character)
+ (encoding-stream-writer stream *default-character-encoding*))
+ (t
+ (warn "no encoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding)))))
+
+
+(defMacro funcall-function.arg (function.arg &rest args)
+ `(funcall (first ,function.arg) (rest ,function.arg) ,@args))
+
+(defun change-stream-decoding (new-encoding)
+ (etypecase new-encoding
+ (keyword t)
+ ((or string (and symbol (not null)))
+ (setf new-encoding (intern (string-upcase new-encoding) "KEYWORD"))))
+ (if (or (eq new-encoding *input-encoding*)
+ (and (eq new-encoding :utf-16)
+ (member *input-encoding* '(:utf-16-12 :utf-16-21))))
+ (values *input-encoding* nil)
+ (multiple-value-bind (function arg detected-encoding to-reread)
+ (decoding-stream-reader *input-source* new-encoding)
+ (unless (and (eq detected-encoding new-encoding)
+ (null to-reread))
+ (error "can't change encoding: ~s: ~s -> ~s = ~s/~s."
+ *input-source*
+ *input-encoding* new-encoding detected-encoding to-reread))
+ (unless function (error "no reader for encoding: ~s." new-encoding))
+ (setf *input-reader* function
+ *input-reader-arg* arg
+ *input-encoding* new-encoding)
+ ;; return the new encoding
+ (values new-encoding t))))
+
+;;
+;;
+;; UTF-8 is computed
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-8)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (let ((reader nil))
+ (setf reader #'(lambda (function.arg &aux byte1)
+ (block read-utf-8-datum
+ (flet ((read-byte-code (&aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (if (integerp byte) byte
+ (return-from read-utf-8-datum nil))))
+ (declare (type fixnum byte1)
+ (ftype (function () fixnum) read-byte-code)
+ (optimize (speed 3) (safety 0)))
+ (setf byte1 (read-byte-code))
+ (cond ((= 0 (logand #x80 byte1))
+ byte1)
+ ((= #xc0 (logand #xe0 byte1))
+ (logior (lsh (logand byte1 #x1f) 6)
+ (logand (read-byte-code) #x3f)))
+ ((= #xe0 (logand #xf0 byte1))
+ (logior (logior (lsh (logand byte1 #x0f) 12)
+ (lsh (logand (read-byte-code) #x3f) 6))
+ (logand (read-byte-code) #x3f)))
+ ((= #xf0 (logand #xf8 byte1))
+ (let ((byte2 (read-byte-code))
+ (byte3 (read-byte-code))
+ (byte4 (read-byte-code)))
+ (xml-error "unsupported unicode datum: ~s."
+ (list byte1 byte2 byte3 byte4))))
+ (t
+ (ecase *illegal-utf-data-condition*
+ ((nil) (funcall reader function.arg))
+ (error (xml-error "illegal UTF-8 data: x~2,'0x." byte1))
+ (warning (xml-warn "illegal UTF-8 data: x~2,'0x." byte1)
+ (funcall reader function.arg)))))))))
+ (values reader
+ (cons function arg)
+ :UTF-8))))
+
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-8)))
+ (if (is-binary-stream stream)
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg char &aux (code (char-code char)))
+ (cond ((<= code #x007f)
+ (funcall-function.arg function.arg code))
+ ((<= code #x07ff)
+ (funcall-function.arg function.arg (logior #b11000000 (lsh code -6)))
+ (funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
+ ((<= code #xffff)
+ (funcall-function.arg function.arg (logior #b11100000 (lsh code -12)))
+ (funcall-function.arg function.arg (logior #b10000000 (logand (lsh code -6) #b00111111)))
+ (funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
+ (t
+ (xml-error "unsupported unicode datum: ~s." code))))
+ (cons function arg)))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg char &aux (code (char-code char)))
+ (cond ((<= code 255)
+ (funcall-function.arg function.arg char))
+ (t
+ (let ((string (format nil "&#~d" code)))
+ (dotimes (x (length string))
+ (funcall-function.arg function.arg (char string x)))))))
+ (cons function arg)))))
+
+;;
+;;
+;; ISO-8859-1 is direct
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :ISO-8859-1)))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (if (is-binary-stream stream)
+ #-(or MCL LispWorks)
+ (multiple-value-bind (reader arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg &aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (when (integerp byte) byte))
+ (cons reader arg)
+ encoding))
+ #+(or MCL LispWorks)
+ (values function arg encoding)
+ ;; character streams must be mapped back to binary
+ (values #'(lambda (function.arg &aux char)
+ (setf char (funcall-function.arg function.arg))
+ (when (characterp char)
+ ;; hardcore tracing
+ ;; (write-char char *trace-output*)
+ (char-code char)))
+ (cons function arg)
+ encoding))))
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :US-ASCII)))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (if (is-binary-stream stream)
+ #-(or MCL LispWorks)
+ (multiple-value-bind (reader arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg &aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (when (integerp byte) byte))
+ (cons reader arg)
+ encoding))
+ #+(or MCL LispWorks)
+ (values function arg encoding)
+ ;; character streams must be mapped back to binary
+ (values #'(lambda (function.arg &aux char)
+ (setf char (funcall-function.arg function.arg))
+ (when (characterp char)
+ (char-code char)))
+ (cons function arg)
+ encoding))))
+
+#+digitool ;; fix eol
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :ISO-8859-1)))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (if (is-binary-stream stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #x0d
+ (char-code char))))
+ (cons function arg)
+ encoding)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #.(code-char #x0d)
+ char)))
+ (cons function arg)
+ encoding))))
+
+#-digitool
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :ISO-8859-1)))
+ (if (is-binary-stream stream)
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg (char-code char)))
+ (cons function arg)
+ encoding))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values function arg encoding))))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :US-ASCII)))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ #+digitool
+ (if (is-binary-stream stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #x0d
+ (char-code char))))
+ (cons function arg)
+ encoding)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #.(code-char #x0d)
+ char)))
+ (cons function arg)
+ encoding))
+ #-digitool
+ (if (is-binary-stream stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg (char-code char)))
+ (cons function arg)
+ encoding)
+ (values function arg encoding))))
+
+;;
+;;
+;; UTF-16 distinguishes encoding order:
+;; UTF-16LE is UTF16 in "little-endian" byte order. (order mark is 0xFF 0xFE)
+;; UTF-16BE is UTF16 in "big-endian" byte order. (order mark is 0xFE 0xFF)
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-16)))
+ (decoding-stream-reader stream *default-utf-16-encoding*))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-16)))
+ (encoding-stream-writer stream *default-utf-16-encoding*))
+
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-16-12)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg)
+ (declare (optimize (speed 3) (safety 0)))
+ (block read-utf-16-datum
+ (flet ((read-byte-code (&aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (if (integerp byte) byte
+ (return-from read-utf-16-datum nil))))
+ (declare (ftype (function () fixnum) read-byte-code))
+ (+ (lsh (read-byte-code) 8) (read-byte-code)))))
+ (cons function arg)
+ encoding)))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-16-12)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg datum)
+ (setf datum (char-code datum))
+ (funcall-function.arg function.arg (logand #xff (lsh datum -8)))
+ (funcall-function.arg function.arg (logand #xff datum)))
+ (cons function arg))))
+
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-16-21)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg)
+ (declare (optimize (speed 3) (safety 0)))
+ (block read-utf-16-datum
+ (flet ((read-byte-code (&aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (if (integerp byte) byte
+ (return-from read-utf-16-datum nil))))
+ (declare (ftype (function () fixnum) read-byte-code))
+ (+ (read-byte-code) (lsh (read-byte-code) 8)))))
+ (cons function arg)
+ encoding)))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-16-21)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg datum)
+ (setf datum (char-code datum))
+ (funcall-function.arg function.arg (logand #xff datum))
+ (funcall-function.arg function.arg (logand #xff (lsh datum -8))))
+ (cons function arg))))
+
+
+
+;;
+;;
+;; detect encoding by reading the initial content. works for binary streams only
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :autodetect)) &aux byte0 byte1 to-reread)
+ "see PR-xml Appendix F"
+ (multiple-value-bind (reader arg) (stream-reader stream)
+ (flet ((next-byte (&aux (byte (funcall reader arg)))
+ (typecase byte
+ (fixnum byte)
+ (t nil))))
+ (case (setf byte0 (next-byte))
+ (#x00 (case (next-byte)
+ (#x00 (case (next-byte)
+ (#x3c (if (= (next-byte) #x00)
+ (setf encoding :UCS-4-2143 to-reread "<")
+ (error "markup stream corrupt: ~s." stream)))
+ (#x00 (if (= (next-byte) #x3c)
+ (setf encoding :UCS-4-1234 to-reread "<")
+ (error "markup stream corrupt: ~s." stream)))
+ (#xFE (if (= (next-byte) #xFF)
+ (setf encoding :UCS-4-1234 to-reread nil)
+ (error "markup stream corrupt: ~s." stream)))
+ (#xFF (if (= (next-byte) #xFE)
+ (setf encoding :UCS-4-2143 to-reread nil)
+ (error "markup stream corrupt: ~s." stream)))
+ (t (error "markup stream corrupt: ~s." stream))))
+ (#x3c (if (= (setf byte1 (next-byte)) #x00)
+ (case (setf byte1 (next-byte))
+ (#x00 (setf encoding :UCS-4-3412 to-reread "<"))
+ (#x3f
+ (when *xml-verbose*
+ (warn "assuming UTF-16-12 encoding for stream: ~s." stream))
+ (setf encoding :UTF-16-12 to-reread "<?"))
+ (t (|EC: Byte Order Mark| :data (list #x00 #x3c #x00 byte1))))
+ (|EC: Byte Order Mark| :data (list #x00 #x3c byte1))))
+ (t
+ (error "markup stream corrupt: ~s." stream))))
+ (#x3c (case (setf byte1 (next-byte))
+ (#x00 (case (setf byte1 (next-byte))
+ (#x3f (case (setf byte1 (next-byte))
+ (#x00
+ (when *xml-verbose*
+ (warn "assuming UTF-16-21 encoding for stream: ~s." stream))
+ (setf encoding :UTF-16-21 to-reread "<?"))
+ (t
+ (|EC: Byte Order Mark| :data (list #x3c #x00 #x3f byte1)))))
+ (#x00 (if (= (next-byte) #x00)
+ (setf encoding :UCS-4-4321 to-reread "<")
+ (|EC: Byte Order Mark| :data (list #x3c #x00 #x00 byte1))))
+ (t
+ (|EC: Byte Order Mark| :data (list #x3c #x00 byte1)))))
+ (#x3f (setf encoding *default-binary-encoding* to-reread "<?"))
+ (t
+ (unless (or (xml-initial-namechar? byte1) (= byte1 #.(char-code #\!)))
+ (when *xml-verbose*
+ (warn "assuming UTF-8 encoding for stream: ~s." stream)))
+ (setf encoding *default-binary-encoding* to-reread (list byte0 byte1)))))
+ (#xEF (case (setf byte1 (next-byte))
+ (#xBB (if (= (setf byte1 (next-byte)) #xBF)
+ (setf encoding :UTF-8 to-reread nil)
+ (|EC: Byte Order Mark| :data (list #xEF #xBB byte1))))
+ (t
+ (|EC: Byte Order Mark| :data (list #xEF byte1)))))
+ (#xff
+ (if (= (setf byte1 (next-byte)) #xfe)
+ (let ((byte2 (next-byte)) (byte3 (next-byte)))
+ (if (and (= byte2 0) (= byte3 0))
+ (setf encoding :UCS4-4321 to-reread nil)
+ (setf encoding :UTF-16-21 to-reread (list (+ byte2 (lsh byte3 8))))))
+ (|EC: Byte Order Mark| :data (list #xff byte1))))
+ (#xfe
+ (if (= (setf byte1 (next-byte)) #xff)
+ (let ((byte2 (next-byte)) (byte3 (next-byte)))
+ (if (and (= byte2 0) (= byte3 0))
+ (setf encoding :UCS4-3412 to-reread nil)
+ (setf encoding :UTF-16-12 to-reread (list (+ (lsh byte2 8) byte3)))))
+ (|EC: Byte Order Mark| :data (list #xfe byte1))))
+ ((nil) ;; no data in stream
+ (setf encoding :UTF-8 to-reread nil))
+ (t
+ (when *xml-verbose*
+ (warn "assuming UTF-8 encoding for stream: ~s." stream))
+ (setf encoding :UTF-8 to-reread (list byte0))))
+ (multiple-value-bind (reader arg encoding) (decoding-stream-reader stream encoding)
+ (values reader arg encoding to-reread)))))
+
+
+
+#|
+
+(defun utf-8-decoding (byte1 &optional (byte2 0) (byte3 0) (byte4 0) &rest ignore)
+ (declare (ignore ignore))
+ (cond ((= 0 (logand #x80 byte1))
+ (values byte1 1))
+ ((= #xc0 (logand #xe0 byte1))
+ (values (logior (lsh (logand byte1 #x1f) 6) (logand byte2 #x3f))
+ 2))
+ ((= #xe0 (logand #xf0 byte1))
+ (values (logior (logior (lsh (logand byte1 #x0f) 12) (lsh (logand byte2 #x3f) 6)) (logand byte3 #x3f))
+ 3))
+ ((= #xf0 (logand #xf8 byte1))
+ (values (logior (logior (lsh (logand byte1 #x03) 18)
+ (lsh (logand byte2 #x3f) 12))
+ (logior (lsh (logand byte3 #x3f) 6)
+ (logand byte4 #x3f)))
+ 4))
+ (t
+ (xml-error "illegal UTF-8 data: #x~2,'0x." byte1))))
+
+(xml-namechar? (utf-8-decoding 194 183 0 0))
+(xml-space? (utf-8-decoding 239 187 191))
+
+(apply #'utf-8-decoding (map 'list #'char-code "༤"))
+
+(defun utf-8-decodingXstring (string)
+ (handler-case
+ (apply #'utf-8-decoding (map 'list #'char-code string))
+ (error (condition) (format nil "~s(~{~2,'0x~}) -> ~a"
+ string (map 'list #'char-code string)
+ condition))))
+
+(format nil "~{~8,'0x~^~%~}" (mapcar #'(lambda (string) (multiple-value-list
+ (utf-8-decodingXstring string)))
+ '("" "氏" "" "�" "�")))
+
+(defGeneric decode-utf8 (source)
+ (:method ((string string)) (decode-utf8 (map 'list #'char-code string)))
+ (:method ((vector vector)) (decode-utf8 (map 'list #'identity vector)))
+ (:method ((source list))
+ (let ((result nil))
+ (loop (unless source (return (reverse result)))
+ (multiple-value-bind (decoded code-unit-count)
+ (apply #'utf-8-decoding source)
+ (push (cons (if (< decoded char-code-limit)
+ (cons (code-char decoded) (format nil "#u~4,'0x" decoded))
+ (format nil "#u~4,'0x" decoded))
+ code-unit-count)
+ result)
+ (setf source (nthcdr code-unit-count source)))))))
+
+(decode-utf8 "asdfqwer")
+(decode-utf8 "")
+(decode-utf8 #(#x3c #x42 #x69 #x72 #x74 #x68 #x43 #x69 #x74 #x79 #x3e #x4b #xef #xbf #xbd #x2f
+ #x42 #x69 #x72 #x74 #x68 #x43 #x69 #x74 #x79 #x3e))
+
+from the 3.1 unicode report
+
+ Table 3.1.
+ UTF-8 Bit Distribution
+ Scalar Value UTF-16 1st Byte 2nd Byte 3rd Byte 4th Byte
+ 00000000 0xxxxxxx 00000000 0xxxxxxx 0xxxxxxx
+
+ 00000yyy yyxxxxxx 00000yyy yyxxxxxx 110yyyyy 10xxxxxx
+
+ zzzzyyyy yyxxxxxx zzzzyyyy yyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx
+
+ 000uuuuu zzzzyyyy 110110ww wwzzzzyy 11110uuu 10uuzzzz 10yyyyyy 10xxxxxx
+ yyxxxxxx 110111yy yyxxxxxx
+
+Where uuuuu = wwww + 1 (to account for addition of 1000016 as in Section 3.7, Surrogates).
+
+|#
+:EOF
1
0
Author: janderson
Date: Mon May 28 07:40:42 2007
New Revision: 16
Added:
trunk/tests/xml/LIBRARY1.xml
- copied unchanged from r15, trunk/tests/xml/LIBRARY2.xml
Removed:
trunk/tests/xml/LIBRARY2.xml
Log:
renamed to eliminate ambiguity
1
0
Author: janderson
Date: Mon May 28 07:39:48 2007
New Revision: 15
Removed:
trunk/tests/xml/LIBRARY1.XML
Log:
delete ambiguous file
1
0
Author: janderson
Date: Mon May 28 07:36:52 2007
New Revision: 14
Added:
trunk/tests/xml/LIBRARY2.xml
- copied unchanged from r13, trunk/tests/xml/LIBRARY1.xml
Removed:
trunk/tests/xml/LIBRARY1.xml
Log:
rename for ambiguous name
1
0
Author: banderson
Date: Tue Feb 14 12:03:43 2006
New Revision: 13
Modified:
branches/sbcl-0.9.x-testing/ (props changed)
Log:
some svn:ignore stuffs
1
0
[cl-xml-cvs] r12 - in branches/sbcl-0.9.x-testing: . code/base library library/de/setf/utility
by banderson＠common-lisp.net 14 Feb '06
by banderson＠common-lisp.net 14 Feb '06
14 Feb '06
Author: banderson
Date: Tue Feb 14 11:57:14 2006
New Revision: 12
Added:
branches/sbcl-0.9.x-testing/cl-xml.asd
Modified:
branches/sbcl-0.9.x-testing/code/base/parameters.lisp
branches/sbcl-0.9.x-testing/library/de/setf/utility/conditions.lisp
branches/sbcl-0.9.x-testing/library/define-system.lisp
branches/sbcl-0.9.x-testing/load.lisp
branches/sbcl-0.9.x-testing/sysdcl.lisp
Log:
rest of changes/hacks for CL-XML to work with SBCL 0.9.8
Added: branches/sbcl-0.9.x-testing/cl-xml.asd
==============================================================================
--- (empty file)
+++ branches/sbcl-0.9.x-testing/cl-xml.asd Tue Feb 14 11:57:14 2006
@@ -0,0 +1,48 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(defpackage #:cl-xml-system
+ (:use #:cl #:asdf))
+
+(in-package #:cl-xml-system)
+
+;; set some options
+(pushnew :xml-symbols *features*)
+(setf *features* (remove :nameset-tokenizer *features*))
+
+;; system
+(defsystem cl-xml
+ :description "Common Lisp support for the 'Extensible Markup Language'"
+ :author "James Anderson <janderson(a)ravenpack.com>"
+ :version "0.949"
+ :licence "LGPL"
+ :components
+ ((:module
+ :library
+ :components
+ ((:file "define-system")))
+ (:file "sysdcl" :depends-on (:library))
+ (:file "load" :depends-on ("sysdcl"))))
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(defpackage #:cl-xml-system
+ (:use #:cl #:asdf))
+
+(in-package #:cl-xml-system)
+
+;; set some options
+(pushnew :xml-symbols *features*)
+(setf *features* (remove :nameset-tokenizer *features*))
+
+;; system
+(defsystem cl-xml
+ :description "Common Lisp support for the 'Extensible Markup Language'"
+ :author "James Anderson <janderson(a)ravenpack.com>"
+ :version "0.949"
+ :licence "LGPL"
+ :components
+ ((:module
+ :library
+ :components
+ ((:file "define-system")))
+ (:file "sysdcl" :depends-on (:library))
+ (:file "load" :depends-on ("sysdcl"))))
Modified: branches/sbcl-0.9.x-testing/code/base/parameters.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/base/parameters.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/base/parameters.lisp Tue Feb 14 11:57:14 2006
@@ -77,7 +77,7 @@
(defVar *xml-base* nil
"binds the base uri to serve as the context when resoving identifiers to URLs.
- parsers bind it to each entity's url to enable rrealtive url references.")
+ parsers bind it to each entity's url to enable relative url references.")
(defVar *xml-verbose* nil
"controls diagnostic messages.")
Modified: branches/sbcl-0.9.x-testing/library/de/setf/utility/conditions.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/library/de/setf/utility/conditions.lisp (original)
+++ branches/sbcl-0.9.x-testing/library/de/setf/utility/conditions.lisp Tue Feb 14 11:57:14 2006
@@ -23,6 +23,9 @@
;; patch restrictive condition implementations
+#+(and sbcl sb-package-locks)
+(sb-ext:unlock-package :cl)
+
(let ((def (fdefinition 'SIMPLE-CONDITION-FORMAT-ARGUMENTS)))
(unless (typep def 'generic-function)
(warn "redefining SIMPLE-CONDITION-FORMAT-ARGUMENTS")
@@ -46,6 +49,8 @@
(defGeneric SIMPLE-CONDITION-FORMAT-string (condition)
(:method ((condition t)) (funcall def condition))))))
+#+(and sbcl sb-package-locks)
+(sb-ext:lock-package :cl)
;;
Modified: branches/sbcl-0.9.x-testing/library/define-system.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/library/define-system.lisp (original)
+++ branches/sbcl-0.9.x-testing/library/define-system.lisp Tue Feb 14 11:57:14 2006
@@ -18,8 +18,6 @@
(defParameter *physical-binary-type*
(pathname-type (compile-file-pathname (make-pathname :name "source" :type *physical-source-type*))))
-#+sbcl
-(setq sb-fasl:*fasl-file-type* "sbcfsl")
(defMacro define-system ((name &key description) (&rest operations) &body files)
(if operations
@@ -98,10 +96,10 @@
(call-with-src-and-bin
#'(lambda (filename src bin probed-src probed-bin)
(if probed-src
- (defsys-message *trace-output*
- "~%; ~s~@[ (@ ~/print-universal-time/)~] -> ~s (~:[missing~;~1:*@ ~/print-universal-time/~])..."
- probed-src (file-write-date probed-src) bin (when probed-bin (file-write-date probed-bin)))
- (warn "file missing: ~s (= ~s)." filename src)))
+ (defsys-message *trace-output*
+ "~%; ~s~@[ (@ ~/print-universal-time/)~] -> ~s (~:[missing~;~1:*@ ~/print-universal-time/~])..."
+ probed-src (file-write-date probed-src) bin (when probed-bin (file-write-date probed-bin)))
+ (warn "file missing: ~s (= ~s)." filename src)))
filename))
(defun system-p (datum)
Modified: branches/sbcl-0.9.x-testing/load.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/load.lisp (original)
+++ branches/sbcl-0.9.x-testing/load.lisp Tue Feb 14 11:57:14 2006
@@ -2,23 +2,24 @@
(in-package :CL-USER)
-;;; load configuration without CL-HTTP and with name symbols:
+;; FIXME: sbcl/clc only right now BSA
+(let ((path "/usr/share/common-lisp/source/cl-xml/"))
-#+CL-HTTP
-(cerror "continue load."
- "this is intended to load a configuration without CL-HTTP, yet CL-HTTP is present.")
-
-(load (merge-pathnames (make-pathname :name "define-system" :directory '(:relative "library"))
- *load-pathname*))
-
-(register-system-definition :xparser (merge-pathnames (make-pathname :name "sysdcl") *load-pathname*))
-
-(pushnew :xml-symbols *features*)
-(setf *features* (remove :nameset-tokenizer *features*))
-(execute-system-operations :xparser '(:compile :load))
-
-(format *trace-output* "~%cl xml loaded:~%~s" *features*)
-
-;(execute-system-operations :xtests '( :load))
-
-:EOF
+;; (or (when *load-truename*
+;; (directory-namestring *load-truename*) )
+;; *default-pathname-defaults*)))
+
+;; (format t "~%~%path: ~a~%~%" path)
+ (format t "~%~%path: ~a~%~%" (merge-pathnames (make-pathname :name "sysdcl") path))
+
+ (register-system-definition :xparser
+ (merge-pathnames
+ (make-pathname :name "sysdcl")
+ path))
+ (execute-system-operations :xparser '(:compile :load))
+
+ (register-system-definition :xpath
+ (merge-pathnames
+ (make-pathname :name "sysdcl")
+ path))
+ (execute-system-operations :xpath '(:compile :load)))
Modified: branches/sbcl-0.9.x-testing/sysdcl.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/sysdcl.lisp (original)
+++ branches/sbcl-0.9.x-testing/sysdcl.lisp Tue Feb 14 11:57:14 2006
@@ -1 +1,414 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*-
#|
<DOCUMENTATION>
<DESCRIPTION>
implementation packages for
<ul>
<li> XQDM: an xml document model which follows the xml-query document
model.</li>
<li> XQ: a serializer (parser/reader and writer functions) for the document
aspects of xml-query algebra expressions based on the XQDM.</li>
<li> XPATH: a parser/reader and interpreter for xpath expressions.</li>
<li> XMLP: a parser for xml expressions based onthe XQDM.</li>
<!-- <li> XMLP: a compatibility package downwards compatible to the older XMLP
package.</li> was considered, but not implemented -->
</ul>
</DESCRIPTION>
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
mailto='james.anderson(a)setf.de' />
<LICENSE href='file://xml/LGPL.txt' >
This library is free software;
With the exceptions noted below, you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version,
as ammended below.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
The terms of the GNU Lesser General Public License are ammended to include
the stipulation, as paragraph 2.e, that any modifications to the library for
the purpose of correcting bugs must be returned to the copyright holder
for inclusion in future versions of the library.
</LICENSE>
<LICENSE href='file://xml/base/tokenizer.lisp'>
the license terms for tokenizer implementation are described in the
respective source file.
</LICENSE>
<LICENSE href='file://xml/bnf/xml-grammar.bnf'>
the www-consortium retains license rights to the respective bnf.
it is distributed herewith under the terms of their software license.</LICENSE>
<LICENSE href='file://xml/bnf/xpath-grammar.bnf'>
the www-consortium retains license rights to the respective bnf.
it is distributed herewith under the terms of their software license.</LICENSE>
<LICENSE href='file://xml/bnf/xql-grammar.bnf'>
the www-consortium retains license rights to the respective bnf.
it is distributed herewith under the terms of their software license.</LICENSE>
<LICENSE href='file://xml/demos/saxandsoap/*.lisp'>
<COPYRIGHT YEAR='2001' AUTHOR='Stanley Knutson' MARK='(C)'
mailto='knewt(a)alum.mit.edu' />
for information on this module, please contact the author.</LICENSE>
<CHRONOLOGY>
<!-- nb. this version number tracks that of the 'parser' module.
the others vary independently. -->
<DELTA DATE='20010605' AUTHOR='MS' VERSION='0.907'>
lispworks/ansi conformance</DELTA>
<DELTA DATE='20010608' VERSION='0.908'>
CL-HTTP in ALLEGRO</DELTA>
<DELTA DATE='20010621'>xml-writer</DELTA>
<DELTA DATE='20010702'>vector-stream moved to utils for data-url support</DELTA>
<DELTA DATE='20010910' VERSION='0.912'>xparser tokenizers</DELTA>
<DELTA DATE='20010910' VERSION='0.914'>0.912+lw/allegro tests</DELTA>
<DELTA DATE='20010918' VERSION='0.915'>first-level tokenization</DELTA>
<DELTA DATE='20011203' VERSION='0.916'>fixes for instance name compilation;<br />
lispworks comm package(including conditionalization 20020115)</DELTA>
<DELTA DATE='20020117'>lispworks charachter element set for two-byte characters</DELTA>
<DELTA DATE='20030408' VERSION='0.949'>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "CL-USER")
(eval-when (:load-toplevel :compile-toplevel :execute)
(let* ((defaults
#+allegro (or *load-truename* *load-pathname* *compile-file-truename*)
#+ccl *load-truename*
#+cmu *load-truename*
#+cormanlisp #p"d:\\Source\\Lisp\\XML-0-918\\sysdcl.lisp"
#+lispWorks (truename (lw:current-pathname))
#+sbcl (or *load-truename* *load-pathname*)
)
(bin-target nil)
(root-target (make-pathname :name :wild :type :wild :version :newest
:directory (append (pathname-directory defaults)
'(:wild-inferiors))
:defaults defaults)))
;; w/o bootstrap lispworks collapsed the bin target to host and type
(setf (logical-pathname-translations "xml")
`(("root;**;*.*.*" ,root-target)))
(setf bin-target
(make-pathname :name :wild
:type (pathname-type (compile-file-pathname "xml:name.lisp"))
:version :newest
:defaults
#+digitool "xml:root;bin;digifasl;**;*.*.*"
#+(and mcl m68k) "xml:root;bin;digim68kfasl;**;*.*.*"
#+(and allegro allegro-version>= (not (version>= 6 0))) "xml:root;bin;acl5fasl;**;*.*.*"
#+(and allegro allegro-version>= (version>= 6 0)) "xml:root;bin;acl6fasl;**;*.*.*"
#+(and lispworks (not mac)) "xml:root;bin;lwfasl;**;*.*.*"
#+(and lispworks mac) "xml:root;bin;lwppcfasl;**;*.*.*"
#+cormanlisp "xml:root;bin;corfasl;**;*.*.*"
#+openmcl "xml:root;bin;omclfasl;**;*.*.*"
#+cmu "xml:root;bin;cmuclfasl;**;*.*.*"
#+sbcl "xml:root;bin;sbclfasl;**;*.*.*"
))
(when *load-verbose*
(format *trace-output* "~%load defaults: ~s.~%compile target: ~s."
defaults bin-target))
(setf (logical-pathname-translations "xml")
`(("**;*.bin.*" ,bin-target)
("**;*.BIN.*" ,bin-target)
("code;**;*.*.*" "xml:root;code;**;*.*.*")
("root;**;*.*.*" ,root-target)
("**;*.bnf.*" "xml:root;bnf;*.*.*")
("**;*.BNF.*" "xml:root;bnf;*.*.*")
("**;*.*.*" "xml:root;**;*.*.*")))
(unless (ignore-errors (LOGICAL-PATHNAME-TRANSLATIONS "Packages"))
(setf (logical-pathname-translations "Packages")
`(("**;*.bin.*" ,bin-target)
("**;*.BIN.*" ,bin-target)
("**;*.*.*" "xml:Library;**;*.*")
("*.*.*" "xml:Library;**;*.*"))))
))
;; configuration
;;
#+CL-HTTP ;; nb. this check is effective in the fasl only
(unless (find :cl-http *features*)
(warn "CL-HTTP not present."))
;;
;; network access
#+(and MCL (not CL-HTTP) (not openmcl))
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-declaration values nil)
(define-declaration arglist nil)
(require "OPENTRANSPORT"))
#+openmcl
(progn
(define-declaration values nil)
(define-declaration arglist nil))
#+(and ALLEGRO (not CL-HTTP))
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "SOCK"))
#+LispWorks
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "comm"))
;; to indicate whether or not to model names as symbols or as instances
;; (pushnew :xml-symbols *features*)
;; to specify the instance names should use tokenizers
(pushnew :nameset-tokenizer *features*)
;; to indicate that all name and string characters are to be checked for legality
;; (pushnew :xml-check-char-codes *features*)
#+Allegro
(when (< excl:real-char-code-limit 65535)
(pushnew :xml-check-char-codes *features*))
#-Allegro
(when (< char-code-limit 65535)
(pushnew :xml-check-char-codes *features*))
#|
;; 20020410.jaa setting the value globally turns out to be inappropriate.
;; the alternative, dynamical binding, is said to be insufficient to affect internal
;; state.
#+LispWorks
(lw:set-default-character-element-type 'lw:simple-char)
;; should that change, the alternative would have been
#+LispWorks ; cause lispworks to use wide-character strings
(lw:*default-character-element-type* 'lw:simple-char)
|#
#+cmu
(progn
(require :gray-streams)
(setq extensions:*inline-expansion-limit* 2)
)
#+sbcl
(progn
(require :gray-streams)
(setq *inline-expansion-limit* 2)
)
#+ccl-5-0-and-0-918
(setq CCL::*CHECK-SLOT-TYPE* nil)
;; the atn-bnf parser must be loaded in order to translate grammars,
;; for regular expressions, and for validation. this is reflected in it presence
;; in the :xparser definition below.
;; nb. this should be refined to load only the minimum for runtime use
(eval-when (:compile-toplevel :execute :load-toplevel)
(define-system
(:base)
()
"xml:code;patch;cmucl"
"xml:library;de;setf;utility;package"
"xml:library;de;setf;utility;string"
"xml:library;de;setf;utility;conditions"
"xml:library;de;setf;utility;test"
"xml:code;base;package"
)
(define-system
(:bnfp)
()
:base
; merged into common package file "xml:code;packages;atn-package"
"xml:code;atn-parser;clifs;inference-system-classes"
"xml:code;atn-parser;clifs;inference-units"
"xml:code;atn-parser;atn-parameters"
"xml:code;atn-parser;atn-classes"
"xml:code;atn-parser;atn-macros"
"xml:code;atn-parser;ebnf-tokenizer"
"xml:code;atn-parser;ebnf-to-atn-translator"
"xml:code;atn-parser;atn-macro-to-canonic-form"
"xml:code;atn-parser;ebnf-grammar.atn" ;; the bnf grammar is coded in a "atn" syntax lisp file.
"xml:code;atn-parser;atn-runtime"
"xml:code;atn-parser;conditions"
"xml:code;atn-parser;atn-lisp-compiler"
"xml:code;atn-parser;atn-regex"
;; the java translator is present here as documentation, as of 20010208 it has
;; not been reintegrated with the changes to compile to lisp.
#+bnfp-java "xml:code;atn-parser;atn-java-compiler"
)
(define-system
(:xutil :description "xml base utilities")
()
:bnfp
"xml:code;base;parameters"
"xml:code;base;cllib"
#+CL-HTTP "xml:code;base;cl-http-utils"
"xml:code;base;utils"
"xml:code;base;parsetable"
"xml:code;base;vector-stream"
#-CL-HTTP "xml:code;base;www-utils-ersatz"
#-CL-HTTP "xml:code;base;tokenizer"
"xml:code;base;conditions")
(define-system
(xqdm :description "model from the x-query data model")
()
:xutil
;; for 0.918 namespaces operations must be defined first
"xml:code;xquerydatamodel;xqdm-namespaces"
"xml:code;xquerydatamodel;xqdm-parameters"
"xml:code;xquerydatamodel;xqdm-character-classes"
"xml:code;xquerydatamodel;xqdm-classes"
"xml:code;xquerydatamodel;xsd-types"
"xml:code;xquerydatamodel;conditions;names;conditions"
"xml:code;xquerydatamodel;conditions;node;conditions"
"xml:code;xquerydatamodel;conditions;model;conditions"
"xml:code;xquerydatamodel;xqdm-operators"
;; "xml:code;xquerydatamodel;xqdm-qnames"
"xml:code;xquerydatamodel;xqdm-validation"
"xml:code;xquerydatamodel;qname-resolution"
"xml:code;xquerydatamodel;xqdm-graph"
"xml:code;xquerydatamodel;node-path-walk"
"xml:code;xquerydatamodel;xqdm-walk"
"xml:code;xquerydatamodel;xqdm-walk-accessors")
(define-system
(xparser :description "xml processor: parsing/serialization for xqdm with standard encoding")
()
:xutil :xqdm
"xml:code;xparser;xml-parameters"
"xml:code;xparser;conditions;codec;conditions"
"xml:code;xparser;xml-stream-coding"
"xml:code;xparser;xml-operators"
"xml:code;xparser;xml-readers"
"xml:code;xparser;xml-tokenizer"
"xml:code;xparser;xml-processing-instruction"
"xml:code;xparser;xml-constructors"
"xml:code;xparser;xml-parser"
"xml:code;xparser;xml-printer"
"xml:code;xparser;xml-writer")
(define-system
(:xpath :description "xml path model and encoding to extend the processor")
()
:xparser
"xml:code;xpath;xpath-parameters"
"xml:code;xpath;xpath-tokenizer"
"xml:code;xpath;xpath-classes"
"xml:code;xpath;xpath-operators"
"xml:code;xpath;xpath-constructors"
"xml:code;xpath;xpath-parser"
"xml:code;xpath;xpath-printer"
"xml:code;xpath;xpath-library")
(define-system
(:xquery :description "xml query processor based on xml processor and xml path")
()
:xparser :xpath
"xml:code;xquery;xq-parameters"
"xml:code;xquery;xqa-classes"
"xml:code;xquery;xqa-operators"
"xml:code;xquery;xql-operators"
"xml:code;xquery;xqa-library"
"xml:code;xquery;xql-library"
"xml:code;xquery;xql-tokenizer"
"xml:code;xquery;xql-constructors"
"xml:code;xquery;xql-parser"
"xml:code;xquery;xq-printer"
)
(define-system
(:xtests
:description
"loads test files")
()
:xparser
"xml:tests;xquerydatamodel;model"
"xml:tests;parser;bom"
"xml:tests;parser;document-internal"
"xml:tests;parser;document-external"
"xml:tests;parser;document-specialized"
"xml:tests;parser;qnames.lisp"
"xml:tests;parser;validation.lisp"
"xml:tests;parser;namespaces.lisp"
"xml:tests;parser;oasis.lisp"
)
(define-system
(:xrelease
:description
"loads test files")
()
:xtests
"xml:code;base;release"
"xml:*.lisp"
"xml:demos;**;*.*"
"xml:library;define-system.lisp"
"xml:**;*.bnf"
"xml:**;*.htm"
"xml:**;*.gif"
"xml:**;*.xql"
"xml:**;*.xml*"
"xml:**;*.dtd"
"xml:**;*.xmlq"
"xml:**;*.txt"
)
(define-system
(:xconformance
:description
"incorporates conformance data files")
()
"xml:standards;XML;XMLConf;**;*.xml"
"xml:standards;XML;XMLConf;**;*.mod"
"xml:standards;XML;XMLConf;**;*.dtd"
"xml:standards;XML;XMLConf;**;*.ent"
"xml:standards;XML;REC-xml-20001006.xml"
"xml:standards;XML;xmlspec-v21.dtd"
"xml:standards;XML;W3CSchema;*.xsd"
"xml:standards;XML;W3CSchema;*.dtd"
"xml:standards;XML;XHTML-MODULAR;**;*.*"
)
)
;; see also xml:tests;test.lisp
;; (load "entwicklung@paz:sourceServer:lisp:xml:define-system.lisp")
;; (register-system-definition :xparser "entwicklung@paz:sourceServer:lisp:xml:sysdcl.lisp")
;; (execute-system-operations :xutil '(:load))
;; (execute-system-operations :xparser '(:load))
;; to test if the pathnames are ok.
;; (execute-system-operations :xparser '(:probe))
;; to load
;; (execute-system-operations :xparser '(:load))
;; (execute-system-operations :xquery '(:load))
;; to compile / load
;; (execute-system-operations :xparser '(:compile))
;; (execute-system-operations :xparser '(:compile :load))
;; (execute-system-operations :xquery '(:compile :load))
;; (execute-system-operations :xquery #'print)
;; (translate-logical-pathname "xml:xxx;yyy;xml-grammar.bnf")
;; (translate-logical-pathname "xml:bnfp;sysdcl")
;; (translate-logical-pathname "xml:code;xquery;xq-printer.lisp")
;; (translate-logical-pathname "xml:code;xquery;xq-printer.bin")
;; (translate-logical-pathname "xml:demo;xq-printer.lisp")
;; (translate-logical-pathname "xml:demo;xq-printer.bin")
:EOF
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*-
+
+#|
+<DOCUMENTATION>
+ <DESCRIPTION>
+ implementation packages for
+ <ul>
+ <li> XQDM: an xml document model which follows the xml-query document
+ model.</li>
+ <li> XQ: a serializer (parser/reader and writer functions) for the document
+ aspects of xml-query algebra expressions based on the XQDM.</li>
+ <li> XPATH: a parser/reader and interpreter for xpath expressions.</li>
+ <li> XMLP: a parser for xml expressions based onthe XQDM.</li>
+ <!-- <li> XMLP: a compatibility package downwards compatible to the older XMLP
+ package.</li> was considered, but not implemented -->
+ </ul>
+ </DESCRIPTION>
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+ mailto='james.anderson(a)setf.de' />
+ <LICENSE href='file://xml/LGPL.txt' >
+ This library is free software;
+ With the exceptions noted below, you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version,
+ as ammended below.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ The terms of the GNU Lesser General Public License are ammended to include
+ the stipulation, as paragraph 2.e, that any modifications to the library for
+ the purpose of correcting bugs must be returned to the copyright holder
+ for inclusion in future versions of the library.
+ </LICENSE>
+ <LICENSE href='file://xml/base/tokenizer.lisp'>
+ the license terms for tokenizer implementation are described in the
+ respective source file.
+ </LICENSE>
+ <LICENSE href='file://xml/bnf/xml-grammar.bnf'>
+ the www-consortium retains license rights to the respective bnf.
+ it is distributed herewith under the terms of their software license.</LICENSE>
+ <LICENSE href='file://xml/bnf/xpath-grammar.bnf'>
+ the www-consortium retains license rights to the respective bnf.
+ it is distributed herewith under the terms of their software license.</LICENSE>
+ <LICENSE href='file://xml/bnf/xql-grammar.bnf'>
+ the www-consortium retains license rights to the respective bnf.
+ it is distributed herewith under the terms of their software license.</LICENSE>
+ <LICENSE href='file://xml/demos/saxandsoap/*.lisp'>
+ <COPYRIGHT YEAR='2001' AUTHOR='Stanley Knutson' MARK='(C)'
+ mailto='knewt(a)alum.mit.edu' />
+ for information on this module, please contact the author.</LICENSE>
+ <CHRONOLOGY>
+ <!-- nb. this version number tracks that of the 'parser' module.
+ the others vary independently. -->
+ <DELTA DATE='20010605' AUTHOR='MS' VERSION='0.907'>
+ lispworks/ansi conformance</DELTA>
+ <DELTA DATE='20010608' VERSION='0.908'>
+ CL-HTTP in ALLEGRO</DELTA>
+ <DELTA DATE='20010621'>xml-writer</DELTA>
+ <DELTA DATE='20010702'>vector-stream moved to utils for data-url support</DELTA>
+ <DELTA DATE='20010910' VERSION='0.912'>xparser tokenizers</DELTA>
+ <DELTA DATE='20010910' VERSION='0.914'>0.912+lw/allegro tests</DELTA>
+ <DELTA DATE='20010918' VERSION='0.915'>first-level tokenization</DELTA>
+ <DELTA DATE='20011203' VERSION='0.916'>fixes for instance name compilation;<br />
+ lispworks comm package(including conditionalization 20020115)</DELTA>
+ <DELTA DATE='20020117'>lispworks charachter element set for two-byte characters</DELTA>
+ <DELTA DATE='20030408' VERSION='0.949'>
+ </CHRONOLOGY>
+ </DOCUMENTATION>
+|#
+
+(in-package "CL-USER")
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (let* ((defaults
+ #+allegro (or *load-truename* *load-pathname* *compile-file-truename*)
+ #+ccl *load-truename*
+ #+cmu *load-truename*
+ #+cormanlisp #p"d:\\Source\\Lisp\\XML-0-918\\sysdcl.lisp"
+ #+lispWorks (truename (lw:current-pathname))
+ #+(and sbcl (not asdf)) (or *compile-file-pathname* *load-pathname* *default-pathname-defaults*)
+ #+(and sbcl asdf) (format nil "~acl-xml/" clc::*source-root*))
+ (bin-target nil)
+ (root-target (make-pathname :name :wild :type :wild :version :newest
+ :directory (append (pathname-directory defaults)
+ '(:wild-inferiors))
+ :defaults defaults)))
+ ;; w/o bootstrap lispworks collapsed the bin target to host and type
+ (setf (logical-pathname-translations "xml")
+ `(("root;**;*.*.*" ,root-target)))
+ (setf bin-target
+ (make-pathname :name :wild
+ :type (pathname-type (compile-file-pathname "xml:name.lisp"))
+ :version :newest
+ :defaults
+;; #-asdf
+;; (progn
+ #+digitool "xml:root;bin;digifasl;**;*.*.*"
+ #+(and mcl m68k) "xml:root;bin;digim68kfasl;**;*.*.*"
+ #+(and allegro allegro-version>= (not (version>= 6 0))) "xml:root;bin;acl5fasl;**;*.*.*"
+ #+(and allegro allegro-version>= (version>= 6 0)) "xml:root;bin;acl6fasl;**;*.*.*"
+ #+lispworks "xml:root;bin;lwfasl;**;*.*.*"
+ #+cormanlisp "xml:root;bin;corfasl;**;*.*.*"
+ #+openmcl "xml:root;bin;omclfasl;**;*.*.*"
+ #+cmu "xml:root;bin;cmuclfasl;**;*.*.*"
+ #+sbcl "xml:root;bin;sbclfasl;**;*.*.*"
+;; )
+;; #+asdf
+;; (progn
+;; (if (find-package :clc)
+;; (format nil "~acl-xml/bin/" clc::*fasl-root*)
+;; "xml:root;bin;sbclfasl;**;*.*.*")) ;; FIXME for non clc
+ ))
+ (when *load-verbose*
+ (format *trace-output* "~%load defaults: ~s.~%compile target: ~s."
+ defaults bin-target))
+ (setf (logical-pathname-translations "xml")
+ `(("**;*.bin.*" ,bin-target)
+ ("**;*.BIN.*" ,bin-target)
+ ("code;**;*.*.*" "xml:root;code;**;*.*.*")
+ ("root;**;*.*.*" ,root-target)
+ ("**;*.bnf.*" "xml:root;bnf;*.*.*")
+ ("**;*.BNF.*" "xml:root;bnf;*.*.*")
+ ("**;*.*.*" "xml:root;**;*.*.*")))
+
+ (unless (ignore-errors (LOGICAL-PATHNAME-TRANSLATIONS "Packages"))
+ (setf (logical-pathname-translations "Packages")
+ `(("**;*.bin.*" ,bin-target)
+ ("**;*.BIN.*" ,bin-target)
+ ("**;*.*.*" "xml:Library;**;*.*")
+ ("*.*.*" "xml:Library;**;*.*"))))
+ ))
+
+;; configuration
+;;
+
+#+CL-HTTP ;; nb. this check is effective in the fasl only
+(unless (find :cl-http *features*)
+ (warn "CL-HTTP not present."))
+
+;;
+;; network access
+#+(and MCL (not CL-HTTP) (not openmcl))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-declaration values nil)
+ (define-declaration arglist nil)
+ (require "OPENTRANSPORT"))
+
+#+openmcl
+(progn
+ (define-declaration values nil)
+ (define-declaration arglist nil))
+
+#+(and ALLEGRO (not CL-HTTP))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "SOCK"))
+#+LispWorks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+;; to indicate whether or not to model names as symbols or as instances
+;; (pushnew :xml-symbols *features*)
+
+;; to specify the instance names should use tokenizers
+ (pushnew :nameset-tokenizer *features*)
+
+;; to indicate that all name and string characters are to be checked for legality
+;; (pushnew :xml-check-char-codes *features*)
+#+Allegro
+(when (< excl:real-char-code-limit 65535)
+ (pushnew :xml-check-char-codes *features*))
+
+#-Allegro
+(when (< char-code-limit 65535)
+ (pushnew :xml-check-char-codes *features*))
+
+#|
+;; 20020410.jaa setting the value globally turns out to be inappropriate.
+;; the alternative, dynamical binding, is said to be insufficient to affect internal
+;; state.
+#+LispWorks
+(lw:set-default-character-element-type 'lw:simple-char)
+
+;; should that change, the alternative would have been
+#+LispWorks ; cause lispworks to use wide-character strings
+(lw:*default-character-element-type* 'lw:simple-char)
+|#
+
+#+cmu
+(progn
+ (require :gray-streams)
+ (setq extensions:*inline-expansion-limit* 2)
+ )
+
+#+sbcl
+(setq *inline-expansion-limit* 2)
+
+#|#+ccl ; 0.918 in 5.0b
+(setq CCL::*CHECK-SLOT-TYPE* nil)|#
+
+;; the atn-bnf parser must be loaded in order to translate grammars,
+;; for regular expressions, and for validation. this is reflected in it presence
+;; in the :xparser definition below.
+;; nb. this should be refined to load only the minimum for runtime use
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+
+ (define-system
+ (:base)
+ ()
+ "xml:code;patch;cmucl"
+ "xml:library;de;setf;utility;package"
+ "xml:library;de;setf;utility;string"
+ "xml:library;de;setf;utility;conditions"
+ "xml:library;de;setf;utility;test"
+ "xml:code;base;package"
+ )
+
+ (define-system
+ (:bnfp)
+ ()
+ :base
+ ; merged into common package file "xml:code;packages;atn-package"
+ "xml:code;atn-parser;clifs;inference-system-classes"
+ "xml:code;atn-parser;clifs;inference-units"
+ "xml:code;atn-parser;atn-parameters"
+ "xml:code;atn-parser;atn-classes"
+ "xml:code;atn-parser;atn-macros"
+ "xml:code;atn-parser;ebnf-tokenizer"
+ "xml:code;atn-parser;ebnf-to-atn-translator"
+ "xml:code;atn-parser;atn-macro-to-canonic-form"
+ "xml:code;atn-parser;ebnf-grammar.atn" ;; the bnf grammar is coded in a "atn" syntax lisp file.
+ "xml:code;atn-parser;atn-runtime"
+ "xml:code;atn-parser;conditions"
+ "xml:code;atn-parser;atn-lisp-compiler"
+ "xml:code;atn-parser;atn-regex"
+ ;; the java translator is present here as documentation, as of 20010208 it has
+ ;; not been reintegrated with the changes to compile to lisp.
+ #+bnfp-java "xml:code;atn-parser;atn-java-compiler"
+ )
+
+ (define-system
+ (:xutil :description "xml base utilities")
+ ()
+ :bnfp
+ "xml:code;base;parameters"
+ "xml:code;base;cllib"
+ #+CL-HTTP "xml:code;base;cl-http-utils"
+ "xml:code;base;utils"
+ "xml:code;base;parsetable"
+ "xml:code;base;vector-stream"
+ #-CL-HTTP "xml:code;base;www-utils-ersatz"
+ #-CL-HTTP "xml:code;base;tokenizer"
+ "xml:code;base;conditions")
+
+ (define-system
+ (xqdm :description "model from the x-query data model")
+ ()
+ :xutil
+ ;; for 0.918 namespaces operations must be defined first
+ "xml:code;xquerydatamodel;xqdm-namespaces"
+ "xml:code;xquerydatamodel;xqdm-parameters"
+ "xml:code;xquerydatamodel;xqdm-character-classes"
+ "xml:code;xquerydatamodel;xqdm-classes"
+ "xml:code;xquerydatamodel;xsd-types"
+ "xml:code;xquerydatamodel;conditions;names;conditions"
+ "xml:code;xquerydatamodel;conditions;node;conditions"
+ "xml:code;xquerydatamodel;conditions;model;conditions"
+ "xml:code;xquerydatamodel;xqdm-operators"
+ ;; "xml:code;xquerydatamodel;xqdm-qnames"
+ "xml:code;xquerydatamodel;xqdm-validation"
+ "xml:code;xquerydatamodel;qname-resolution"
+ "xml:code;xquerydatamodel;xqdm-graph"
+ "xml:code;xquerydatamodel;node-path-walk"
+ "xml:code;xquerydatamodel;xqdm-walk"
+ "xml:code;xquerydatamodel;xqdm-walk-accessors")
+
+ (define-system
+ (xparser :description "xml processor: parsing/serialization for xqdm with standard encoding")
+ ()
+ :xutil :xqdm
+ "xml:code;xparser;xml-parameters"
+ "xml:code;xparser;conditions;codec;conditions"
+ "xml:code;xparser;xml-stream-coding"
+ "xml:code;xparser;xml-operators"
+ "xml:code;xparser;xml-readers"
+ "xml:code;xparser;xml-tokenizer"
+ "xml:code;xparser;xml-processing-instruction"
+ "xml:code;xparser;xml-constructors"
+ "xml:code;xparser;xml-parser"
+ "xml:code;xparser;xml-printer"
+ "xml:code;xparser;xml-writer")
+
+ (define-system
+ (:xpath :description "xml path model and encoding to extend the processor")
+ ()
+ :xparser
+ "xml:code;xpath;xpath-parameters"
+ "xml:code;xpath;xpath-tokenizer"
+ "xml:code;xpath;xpath-classes"
+ "xml:code;xpath;xpath-operators"
+ "xml:code;xpath;xpath-constructors"
+ "xml:code;xpath;xpath-parser"
+ "xml:code;xpath;xpath-printer"
+ "xml:code;xpath;xpath-library")
+
+ (define-system
+ (:xquery :description "xml query processor based on xml processor and xml path")
+ ()
+ :xparser :xpath
+ "xml:code;xquery;xq-parameters"
+ "xml:code;xquery;xqa-classes"
+ "xml:code;xquery;xqa-operators"
+ "xml:code;xquery;xql-operators"
+ "xml:code;xquery;xqa-library"
+ "xml:code;xquery;xql-library"
+ "xml:code;xquery;xql-tokenizer"
+ "xml:code;xquery;xql-constructors"
+ "xml:code;xquery;xql-parser"
+ "xml:code;xquery;xq-printer"
+ )
+
+ (define-system
+ (:xtests
+ :description
+ "loads test files")
+ ()
+ :xparser
+
+ "xml:tests;xquerydatamodel;model"
+
+ "xml:tests;parser;bom"
+ "xml:tests;parser;document-internal"
+ "xml:tests;parser;document-external"
+ "xml:tests;parser;document-specialized"
+ "xml:tests;parser;qnames.lisp"
+ "xml:tests;parser;validation.lisp"
+ "xml:tests;parser;namespaces.lisp"
+ "xml:tests;parser;oasis.lisp"
+ )
+
+ (define-system
+ (:xrelease
+ :description
+ "loads test files")
+ ()
+ :xtests
+ "xml:code;base;release"
+ "xml:*.lisp"
+ "xml:demos;**;*.*"
+ "xml:library;define-system.lisp"
+ "xml:**;*.bnf"
+ "xml:**;*.htm"
+ "xml:**;*.gif"
+ "xml:**;*.xql"
+ "xml:**;*.xml*"
+ "xml:**;*.dtd"
+ "xml:**;*.xmlq"
+ "xml:**;*.txt"
+ )
+
+ (define-system
+ (:xconformance
+ :description
+ "incorporates conformance data files")
+ ()
+ "xml:standards;XML;XMLConf;**;*.xml"
+ "xml:standards;XML;XMLConf;**;*.mod"
+ "xml:standards;XML;XMLConf;**;*.dtd"
+ "xml:standards;XML;XMLConf;**;*.ent"
+ "xml:standards;XML;REC-xml-20001006.xml"
+ "xml:standards;XML;xmlspec-v21.dtd"
+ "xml:standards;XML;W3CSchema;*.xsd"
+ "xml:standards;XML;W3CSchema;*.dtd"
+ "xml:standards;XML;XHTML-MODULAR;**;*.*"
+ )
+ )
+
+
+;; see also xml:tests;test.lisp
+;; (load "entwicklung@paz:sourceServer:lisp:xml:define-system.lisp")
+;; (register-system-definition :xparser "entwicklung@paz:sourceServer:lisp:xml:sysdcl.lisp")
+;; (execute-system-operations :xutil '(:load))
+;; (execute-system-operations :xparser '(:load))
+
+;; to test if the pathnames are ok.
+;; (execute-system-operations :xparser '(:probe))
+
+;; to load
+;; (execute-system-operations :xparser '(:load))
+;; (execute-system-operations :xquery '(:load))
+
+;; to compile / load
+;; (execute-system-operations :xparser '(:compile))
+;; (execute-system-operations :xparser '(:compile :load))
+;; (execute-system-operations :xquery '(:compile :load))
+
+;; (execute-system-operations :xquery #'print)
+
+;; (translate-logical-pathname "xml:xxx;yyy;xml-grammar.bnf")
+;; (translate-logical-pathname "xml:bnfp;sysdcl")
+;; (translate-logical-pathname "xml:code;xquery;xq-printer.lisp")
+;; (translate-logical-pathname "xml:code;xquery;xq-printer.bin")
+;; (translate-logical-pathname "xml:demo;xq-printer.lisp")
+;; (translate-logical-pathname "xml:demo;xq-printer.bin")
+
+:EOF
1
0
14 Feb '06
Author: banderson
Date: Tue Feb 14 11:56:21 2006
New Revision: 11
Modified:
branches/sbcl-0.9.x-testing/code/base/utils.lisp
Log:
bad hack to get around endless loop - this is *not* the permanent solution, because James Anderson already reported it doesn't work for his Lisp (some *MCL). However, this works for SBCL.
Modified: branches/sbcl-0.9.x-testing/code/base/utils.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/base/utils.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/base/utils.lisp Tue Feb 14 11:56:21 2006
@@ -393,7 +393,7 @@
(setf default-host (host-string defaults)
default-path (path defaults))
(return))
- (string (setf defaults (make-uri defaults nil)))
+ (string (return)) ;;(setf defaults (make-uri defaults nil)))
(pathname (setf defaults (pathname-file-url defaults)))
(urn (return))
(null (return))))
@@ -590,6 +590,11 @@
"allow host, ignore device, which should be :unspecific"
(let ((host (pathname-host pathname)))
(when (eq host :unspecific) (setf host nil))
+ #+sbcl
+ (progn
+ (setf host nil)
+ (setf pathname (translate-logical-pathname pathname)))
+
(pathname-file-url (format nil "file://~@[~a~]/~{~a/~}~a~@[.~a~]"
host
(rest (pathname-directory pathname))
1
0
14 Feb '06
Author: banderson
Date: Tue Feb 14 11:54:45 2006
New Revision: 10
Modified:
branches/sbcl-0.9.x-testing/code/base/package.lisp
Log:
some re-arranging from old releases
Modified: branches/sbcl-0.9.x-testing/code/base/package.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/base/package.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/base/package.lisp Tue Feb 14 11:54:45 2006
@@ -1 +1,1070 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*-
#|
<DOCUMENTATION>
nb. see XQueryDataModel:XQDM-classes for exports for class predicate and constructors
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
href='file://xml/sysdcl.lisp' /> <CHRONOLOGY>
<DELTA DATE='20010507'>incorporated character class exports</DELTA>
<DELTA DATE='20010617'>moved parsetable to XML-UTILS</DELTA>
<DELTA DATE='20010621'>exported xml serialization iterface</DELTA>
<DELTA DATE='20010622'>parameters for reader adjustments for null symbol names</DELTA>
<DELTA DATE='20010624'>node graph interface</DELTA>
<DELTA DATE='20010702'><code>DATA-URL</code>; differentiated qname contexts</DELTA>
<DELTA DATE='20010714'>factored namespaces out</DELTA>
<DELTA DATE='20010718'>xmlparser package renamed to XMLP</DELTA>
<DELTA DATE='20010808'>added '$' package for XQL variables</DELTA>
<DELTA DATE='20010816'>additions for schema types</DELTA>
<DELTA DATE='20010902'>www-utils and tk1 package for cl-http tokenizer</DELTA>
<DELTA DATE='20030320'>added 0.950 package nicknmes inorder to use its condition implementation</DELTA>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "CL-USER")
(defPackage "BNF-PARSER"
(:nicknames "BNFP")
(:use :common-lisp #+:ccl :ccl #+lispworks :harlequin-common-lisp :de.setf.utility.conditions )
(:shadow "SYMBOL")
#+Allegro (:import-from "EXCL" "WITHOUT-INTERRUPTS")
#+(and Allegro (version>= 6 0)) (:import-from "MOP" "CLASS-PRECEDENCE-LIST")
#+(and Allegro (version< 6 0)) (:import-from "CLOS" "CLASS-PRECEDENCE-LIST")
#+Genera (:import-from "CLOS-INTERNALS" "CLASS-PRECEDENCE-LIST" "FUNCALLABLE-STANDARD-CLASS" "VALIDATE-SUPERCLASS")
#+Genera(:import-from "SCL" "WITHOUT-INTERRUPTS")
#+Genera(:shadowing-import-from "SI" "STREAM")
#+lispworks (:import-from :lispworks :without-interrupts)
#+CMU (:import-from "SYSTEM" "WITHOUT-INTERRUPTS")
#+PCL (:shadowing-import-from "PCL" "CLASS-PRECEDENCE-LIST"
"FUNCALLABLE-STANDARD-CLASS"
"VALIDATE-SUPERCLASS"
"STANDARD-CLASS" "BUILT-IN-CLASS"
"FIND-CLASS" "CLASS-NAME" "CLASS-OF")
#+SBCL (:import-from "SB-SYS" "WITHOUT-INTERRUPTS")
#+sbcl (:shadowing-import-from "SB-PCL" "CLASS-PRECEDENCE-LIST"
"FUNCALLABLE-STANDARD-CLASS"
"VALIDATE-SUPERCLASS"
"STANDARD-CLASS" "BUILT-IN-CLASS"
"FIND-CLASS" "CLASS-NAME" "CLASS-OF")
(:export
"*ATN-CLASS"
"*ATN-LEVEL"
"*ATN-NET"
"*ATN-NODE"
"*ATN-PROPERTIES"
"*ATN-REGISTER-WORDS"
"*ATN-SAVE-DEFINITIONS*"
"*ATN-STACK"
"*ATN-STRUCTURE*"
"*ATN-TERM*"
"*ATN-TERM?*"
"*ATN-TOKEN-PACKAGE*"
"*ATN-TRACE*"
"*ATN-TRACE-NETS*"
"*ATN-WFST"
"*CLASS.ATN*"
"*CLASS.ATN-ALTERNATIVE-CATEGORY*"
"*CLASS.ATN-BUILTIN-PREDICATE-CATEGORY*"
"*CLASS.ATN-CELL-CATEGORY*"
"*CLASS.ATN-COMPLEMENT-CATEGORY*"
"*CLASS.ATN-CONJUNCTION*"
"*CLASS.ATN-DERIVED-CATEGORY*"
"*CLASS.ATN-LEXEM*"
"*CLASS.ATN-LEXICON*"
"*CLASS.ATN-NEGATED-ALTERNATIVES*"
"*CLASS.ATN-NODE*"
"*CLASS.ATN-PRIMITIVE-CATEGORY*"
"*CLASS.ATN-UNDECLARED-CATEGORY*"
"*CLASS.CAT-ATN-EDGE*"
"*CLASS.CELL-ATN-EDGE*"
"*CLASS.JUMP-ATN-EDGE*"
"*CLASS.OR-ATN-EDGE*"
"*CLASS.POP-ATN-EDGE*"
"*CLASS.PUSH-ATN-EDGE*"
"*CLASS.TEST-ATN-EDGE*"
"*CLASS.WORD-ATN-EDGE*"
"*SOURCE-RECORDING*"
:*terminal-parser-error-action*
"ATN"
"ATN-ALTERNATIVE-CATEGORY"
"ATN-BINDINGS"
"ATN-BUILTIN-PREDICATE-CATEGORY"
"ATN-CELL-CATEGORY"
"ATN-COMPLEMENT-CATEGORY"
"ATN-CONJUNCTION"
"ATN-CONSTRUCTOR-SPECIALIZER"
"ATN-CONTINUE-ACTIONS"
"ATN-DERIVED-CATEGORY"
"ATN-FAIL-ACTIONS"
"ATN-FINALLY"
"ATN-INITIAL-ACTIONS"
"ATN-INPUT"
"ATN-LEXEM"
"ATN-LEXICON"
"ATN-NAME"
"ATN-NEGATED-ALTERNATIVES"
"ATN-NODE"
"ATN-PRIMITIVE-CATEGORY"
"ATN-PROCEDURE-CALL"
"ATN-RECURSION"
"ATN-REDUCE-ITEM"
"ATN-REDUCE-STRUCTURE"
"ATN-SEQUENCE-INPUT"
"ATN-STACK"
"ATN-SUCCEED-ACTIONS"
"ATN-TERM-CARDINALITY"
"ATN-TERM-NAMES"
"ATN-UNDECLARED-CATEGORY"
"BNF-TO-REGEX-ATN"
"CALL-WITH-PARSED-ALIST"
"CALL-WITH-PARSED-TERMS"
"CAT-ATN-EDGE"
"CELL-ATN-EDGE"
"COMPILE-ATN-SYSTEM"
"CONSTRUCTOR-SPECIALIZERS"
"CONTINUABLE-PARSER-ERROR"
"FIND-PARSED-TERM"
"INFERENCE-SYSTEM"
"INFERENCE-UNIT"
"INPUT.IS-AT-END"
"INPUT.ITEM"
"INPUT.LAST-ITEM"
"INPUT.LENGTH"
"INPUT.PEEK-ITEM"
"INPUT.REPLACE-ITEM"
"IS-ATN-TRACE"
"IS-REDUCTION-ENABLED"
"JUMP-ATN-EDGE"
"MAKE-LISP-FORM"
"MAKE-LISP-SUBFORM"
"MAKE-LISP-TEST-FORM"
"MATCH-REGEX"
"NTH-PARSE-RESULT"
"OR-ATN-EDGE"
"PARSER-EOF-ERROR"
"PARSER-ERROR"
"PARSE-RESULT"
"POP-ATN-EDGE"
"PPRINT-ATN"
"PUSH-ATN-EDGE"
"REGULAR-EXPRESSION-TO-REGEX-ATN"
"RULE"
"RULE-DOCUMENTATION"
"RULE-NAME"
"RULE-SOURCES"
"SORT-PARSE-RESULTS"
"SYSTEM"
"SYSTEM-DOCUMENTATION"
"SYSTEM-NAME"
"SYSTEM-PLIST"
"TERMINAL-PARSER-ERROR"
"TEST-ATN-EDGE"
"WITH-PARSED-ALIST"
"WITH-PARSED-PLIST"
"WITH-PARSED-TERM"
"WORD-ATN-EDGE"
;; for parse states
:condition-parse-state
:condition-action
:parse-state
:parse-state-condition
:parse-state-source
:parse-state-term
:parse-state-non-terminal
:parse-state-stack
:parse-state-active-p
:print-parse-state
:make-parse-state
))
(defPackage "XML-UTILS"
(:nicknames "XUTILS" :de.setf.xml.base.implementation
:de.setf.xml.conditions)
(:use :common-lisp #+ccl :ccl
:de.setf.utility.conditions)
#+CCL (:import-from "CCL" "STREAM-POSITION")
#+CL-HTTP (:import-from "URL" "URI" "URL" "PARSE-URL" "INTERN-URL"
"HTTP-URL" "FILE-URL" "NAME-STRING"
"PATH" "HOST" "HOST-STRING" "PORT" "OBJECT" "EXTENSION"
"TRANSLATED-PATHNAME"
;; for the file-url function
"DIRECTORY-NAME-STRING" "WITH-VALUE-CACHED"
"WRITE-SCHEME-PREFIX" "WRITE-HOST-PORT-STRING" "WRITE-PATH")
#+CL-HTTP (:import-from "HTTP" "MERGE-URL")
#+ALLEGRO (:import-from "EXCL" "WITHOUT-INTERRUPTS")
#+lispworks (:import-from :lispworks :without-interrupts)
#+CMU (:import-from "SYSTEM" "WITHOUT-INTERRUPTS")
#+PCL (:shadowing-import-from "PCL" "CLASS-PRECEDENCE-LIST"
"FUNCALLABLE-STANDARD-CLASS"
"VALIDATE-SUPERCLASS" "STANDARD-CLASS"
"BUILT-IN-CLASS" "FIND-CLASS"
"CLASS-NAME" "CLASS-OF")
#+SBCL (:import-from "SB-SYS" "WITHOUT-INTERRUPTS")
#+sbcl (:shadowing-import-from "SB-PCL" "CLASS-PRECEDENCE-LIST"
"FUNCALLABLE-STANDARD-CLASS"
"VALIDATE-SUPERCLASS" "STANDARD-CLASS"
"BUILT-IN-CLASS" "FIND-CLASS"
"CLASS-NAME" "CLASS-OF")
#+digitool
(:import-from :ccl
:stream-reader
:stream-writer
:stream-column)
(:import-from :de.setf.utility.test
:deftest
:deftests
:execute-tests)
(:EXPORT
:deftest
:deftests
:execute-tests
"*ENCODING-MAP*"
"*PARSETABLE*"
"*TOKEN-PACKAGE*"
"*XML-BASE*"
"*XML-VERBOSE*"
"<-CHAR-CODE-LIMIT"
"CANONICAL-ENCODING"
"CHECKED-CODE-CHAR"
"CLEAR-PARSETABLE"
"CLEAR-PARSETABLES"
"COMPUTE-PARSER-MACROS"
"COMPUTE-TOKEN-READER"
"COPY-PARSETABLE"
"DATA-URL"
"DEFALTERNATIVECONSTRUCTOR"
"DEFCONSTANTCONSTRUCTOR"
"DEFCONSTRUCTOR"
"DEFCONSTRUCTORMETHOD"
"DEFIDENTITYCONSTRUCTOR"
"DEFLITERALCONSTRUCTOR"
"DEFNULLCONSTRUCTOR"
"DEFPARSETABLE"
"DEFTOKEN"
"DEFTOKENCONSTRUCTOR"
"DEFTOKENCONSTRUCTORS"
"DEFTOKENS"
"EXPORT-NAME"
"FILE-URL"
"FILE-URL-PATHNAME"
"HTTP-URL"
"MAKE-DATA-URL"
"MAKE-URI"
"MERGE-URIS"
"NOTE-newline-200101314"
:object
"PARSER-MACRO"
"PARSETABLE"
"PATHNAME-FILE-URL"
"REC-xml-19980210.End-of-Line Handling"
"REC-xml-19980210.PEs in Internal Subset"
"REC-xml-19980210.Validate Attribute Defaults"
"REC-xml-names-19990114"
"REC-xml-names-19990114.NSC: Prefix Immutable"
"REC-xml-names-19990114.VC: Attribute Declared"
"RESOLVE-ENTITY-IDENTIFIERS"
"SPLIT-SEQ"
"SPLIT-STRING"
"STREAM-POSITION"
"STREAM-STATE"
"TABLE.MACROS"
"TABLE.NAME"
"TABLE.PROPERTIES"
"URI"
"URI-NAMESTRING"
"URL"
"URL-DATA"
"URN"
"VECTOR-INPUT-STREAM"
"WITH-DATA-STREAM"
"WITH-FILE-STREAM"
"WITH-HTTP-STREAM"
"WITH-PARSETABLE"
"WITHOUT-INTERRUPTS"
"STREAM-COLUMN"
"STREAM-READER"
"STREAM-WRITER"
:check-constraint
:coerce-to-generic-function
:condition-continue-format-arguments
:condition-continue-format-control
:continuable-error
:continue-format-arguments
:continue-format-control
:defexception
:initialize-condition
:internal-xml-error
:make-initialized-condition
:report-condition
:report-condition
:simple-continuable-condition
:xml-condition
:xml-error
:xml-warn
:xml-warning
:|VC: ID|
:|VC: Name Token|
:|VC: Entity Name|
:|VC: Notation Attributes|
:|VC: Enumeration|
:|VC: Element Content|
:|VC: No Duplicate Tokens|
:|VC: No Duplicate Types|
:|NSC: Prefix Immutable|
:|WFC: Legal Character|
))
(defPackage "XML-QUERY-DATA-MODEL"
(:nicknames "XQDM"
:DE.SETF.XML.NAMES.IMPLEMENTATION
:DE.SETF.XML.NODE.IMPLEMENTATION
:DE.SETF.XML.MODEL
:DE.SETF.XML.MODEL.IMPLEMENTATION)
(:shadowing-import-from "BNFP" "PARSE-ERROR")
#+LISPWORKS
(:import-from "HCL" "VALIDATE-SUPERCLASS")
(:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XUTILS")
#+CCL (:shadow "TARGET")
#+PCL (:shadowing-import-from "PCL" "CLASS-PRECEDENCE-LIST"
"FUNCALLABLE-STANDARD-CLASS"
"VALIDATE-SUPERCLASS" "STANDARD-CLASS"
"BUILT-IN-CLASS" "FIND-CLASS"
"CLASS-NAME" "CLASS-OF"
"STRUCTURE-CLASS")
#+sbcl (:shadowing-import-from "SB-PCL" "CLASS-PRECEDENCE-LIST"
"FUNCALLABLE-STANDARD-CLASS"
"VALIDATE-SUPERCLASS" "STANDARD-CLASS"
"BUILT-IN-CLASS" "FIND-CLASS"
"CLASS-NAME" "CLASS-OF")
(:export
;; the defTypePredicate macro exports for classes and predicate names
;; the defException macro exports exception class names
"ABSTRACT-CLASS"
"ABSTRACT-NODE"
"NAMED-NODE"
"UNAMED-NODE"
"NCNAMED-NODE"
"TYPED-NODE"
"DOCUMENT-SCOPED-NODE"
"ORDINAL-NODE"
"ENTITY-DELEGATE"
"DOC-NODE-INTERFACE"
"ELEM-NODE-INTERFACE"
"ELEM-PROPERTY-NODE-INTERFACE"
;; model classes: all classes export the symbol and a predicate
;; concrete classes have an instantiation function and parameter
;; see defTypePredicate for generation
"ABSTRACT-ATTR-NODE" "IS-ABSTRACT-ATTR-NODE"
"ABSTRACT-DEF-NODE" "IS-ABSTRACT-DEF-NODE"
"ABSTRACT-DEF-TYPE" "IS-ABSTRACT-DEF-TYPE"
"ABSTRACT-ELEM-NODE" "IS-ABSTRACT-ELEM-NODE"
"ABSTRACT-ELEM-PROPERTY-NODE" "IS-ABSTRACT-ELEM-PROPERTY-NODE"
"ABSTRACT-NS-NODE" "IS-ABSTRACT-NS-NODE"
"ABSTRACT-TOP-LEVEL-DEF-NODE" "IS-ABSTRACT-TOP-LEVEL-DEF-NODE"
"ATTR-CHILD-NODE" "IS-ATTR-CHILD-NODE" "*CLASS.ATTR-CHILD-NODE*" "MAKE-ATTR-CHILD-NODE"
"ATTR-NODE" "IS-ATTR-NODE" "*CLASS.ATTR-NODE*" "MAKE-ATTR-NODE"
"BINARY-VALUE" "IS-BINARY-VALUE" "*CLASS.BINARY-VALUE*" "MAKE-BINARY-VALUE"
"BOOL-VALUE" "IS-BOOL-VALUE" "*CLASS.BOOL-VALUE*" "MAKE-BOOL-VALUE"
"CHARACTER-DATA-NODE" "IS-CHARACTER-DATA-NODE" "*CLASS.CHARACTER-DATA-NODE*" "MAKE-CHARACTER-DATA-NODE"
"COMMENT-NODE" "IS-COMMENT-NODE" "*CLASS.COMMENT-NODE*" "MAKE-COMMENT-NODE"
"CONDITIONAL-SECTION" "IS-CONDITIONAL-SECTION" "*CLASS.CONDITIONAL-SECTION*" "MAKE-CONDITIONAL-SECTION"
"DECIMAL-ATTR-NODE" "IS-DECIMAL-ATTR-NODE" "*CLASS.DECIMAL-ATTR-NODE*" "MAKE-DECIMAL-ATTR-NODE"
"DECIMAL-VALUE" "IS-DECIMAL-VALUE" "*CLASS.DECIMAL-VALUE*" "MAKE-DECIMAL-VALUE"
"DEF-ATTR" "IS-DEF-ATTR" "*CLASS.DEF-ATTR*" "MAKE-DEF-ATTR"
"DEF-ELEM-PROPERTY-TYPE" "IS-DEF-ELEM-PROPERTY-TYPE" "*CLASS.DEF-ELEM-PROPERTY-TYPE*" "MAKE-DEF-ELEM-PROPERTY-TYPE"
"DEF-ELEM-TYPE" "IS-DEF-ELEM-TYPE" "*CLASS.DEF-ELEM-TYPE*" "MAKE-DEF-ELEM-TYPE"
"DEF-ENTITY" "IS-DEF-ENTITY" "*CLASS.DEF-ENTITY*" "MAKE-DEF-ENTITY"
"DEF-EXTERNAL-ENTITY" "IS-DEF-EXTERNAL-ENTITY" "*CLASS.DEF-EXTERNAL-ENTITY*" "MAKE-DEF-EXTERNAL-ENTITY"
"DEF-EXTERNAL-GENERAL-ENTITY" "IS-DEF-EXTERNAL-GENERAL-ENTITY" "*CLASS.DEF-EXTERNAL-GENERAL-ENTITY*" "MAKE-DEF-EXTERNAL-GENERAL-ENTITY"
"DEF-EXTERNAL-PARAMETER-ENTITY" "IS-DEF-EXTERNAL-PARAMETER-ENTITY" "*CLASS.DEF-EXTERNAL-PARAMETER-ENTITY*" "MAKE-DEF-EXTERNAL-PARAMETER-ENTITY"
"DEF-GENERAL-ENTITY" "IS-DEF-GENERAL-ENTITY" "*CLASS.DEF-GENERAL-ENTITY*" "MAKE-DEF-GENERAL-ENTITY"
"DEF-INTERNAL-ENTITY" "IS-DEF-INTERNAL-ENTITY" "*CLASS.DEF-INTERNAL-ENTITY*" "MAKE-DEF-INTERNAL-ENTITY"
"DEF-INTERNAL-GENERAL-ENTITY" "IS-DEF-INTERNAL-GENERAL-ENTITY" "*CLASS.DEF-INTERNAL-GENERAL-ENTITY*" "MAKE-DEF-INTERNAL-GENERAL-ENTITY"
"DEF-INTERNAL-PARAMETER-ENTITY" "IS-DEF-INTERNAL-PARAMETER-ENTITY" "*CLASS.DEF-INTERNAL-PARAMETER-ENTITY*" "MAKE-DEF-INTERNAL-PARAMETER-ENTITY"
"DEF-NOTATION" "IS-DEF-NOTATION" "*CLASS.DEF-NOTATION*" "MAKE-DEF-NOTATION"
"DEF-PARAMETER-ENTITY" "IS-DEF-PARAMETER-ENTITY" "*CLASS.DEF-PARAMETER-ENTITY*" "MAKE-DEF-PARAMETER-ENTITY"
"DEFNAMESPACE"
"DOC-CHILD-NODE" "IS-DOC-CHILD-NODE" "*CLASS.DOC-CHILD-NODE*" "MAKE-DOC-CHILD-NODE"
"DOC-NODE" "IS-DOC-NODE" "*CLASS.DOC-NODE*" "MAKE-DOC-NODE"
"DOCTYPE-CHILD-NODE" "IS-DOCTYPE-CHILD-NODE" "*CLASS.DOCTYPE-CHILD-NODE*" "MAKE-DOCTYPE-CHILD-NODE"
"DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE" "IS-DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE" "*CLASS.DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE*" "MAKE-DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE"
"DOUBLE-ATTR-NODE" "IS-DOUBLE-ATTR-NODE" "*CLASS.DOUBLE-ATTR-NODE*" "MAKE-DOUBLE-ATTR-NODE"
"DOUBLE-VALUE" "IS-DOUBLE-VALUE" "*CLASS.DOUBLE-VALUE*" "MAKE-DOUBLE-VALUE"
"ELEM-CHILD-NODE" "IS-ELEM-CHILD-NODE" "*CLASS.ELEM-CHILD-NODE*" "MAKE-ELEM-CHILD-NODE"
"ELEM-NODE" "IS-ELEM-NODE" "*CLASS.ELEM-NODE*" "MAKE-ELEM-NODE"
"ELEM-PROPERTY-NODE" "IS-ELEM-PROPERTY-NODE" "*CLASS.ELEM-PROPERTY-NODE*" "MAKE-ELEM-PROPERTY-NODE"
"ENTITIES-ATTR-NODE" "IS-ENTITIES-ATTR-NODE" "*CLASS.ENTITIES-ATTR-NODE*" "MAKE-ENTITIES-ATTR-NODE"
"ENTITY-ATTR-NODE" "IS-ENTITY-ATTR-NODE" "*CLASS.ENTITY-ATTR-NODE*" "MAKE-ENTITY-ATTR-NODE"
"ENTITY-INFORMATION-NODE" "IS-ENTITY-INFORMATION-NODE" "*CLASS.ENTITY-INFORMATION-NODE*" "MAKE-ENTITY-INFORMATION-NODE"
"ENTITY-VALUE" "IS-ENTITY-VALUE" "*CLASS.ENTITY-VALUE*" "MAKE-ENTITY-VALUE"
"ENUMERATION-ATTR-NODE" "IS-ENUMERATION-ATTR-NODE" "*CLASS.ENUMERATION-ATTR-NODE*" "MAKE-ENUMERATION-ATTR-NODE"
"EXT-SUBSET-NODE" "IS-EXT-SUBSET-NODE" "*CLASS.EXT-SUBSET-NODE*" "MAKE-EXT-SUBSET-NODE"
"EXTERNAL-PARSED-ENTITY" "IS-EXTERNAL-PARSED-ENTITY" "*CLASS.EXTERNAL-PARSED-ENTITY*" "MAKE-EXTERNAL-PARSED-ENTITY"
"FLOAT-VALUE" "IS-FLOAT-VALUE" "*CLASS.FLOAT-VALUE*" "MAKE-FLOAT-VALUE"
"FUNCTION-VALUE" "IS-FUNCTION-VALUE" "*CLASS.FUNCTION-VALUE*" "MAKE-FUNCTION-VALUE"
"ID-ATTR-NODE" "IS-ID-ATTR-NODE" "*CLASS.ID-ATTR-NODE*" "MAKE-ID-ATTR-NODE"
"ID-REF-ATTR-NODE" "IS-ID-REF-ATTR-NODE" "*CLASS.ID-REF-ATTR-NODE*" "MAKE-ID-REF-ATTR-NODE"
"ID-REF-VALUE" "IS-ID-REF-VALUE" "*CLASS.ID-REF-VALUE*" "MAKE-ID-REF-VALUE"
"ID-REFS-ATTR-NODE" "IS-ID-REFS-ATTR-NODE" "*CLASS.ID-REFS-ATTR-NODE*" "MAKE-ID-REFS-ATTR-NODE"
"ID-VALUE" "IS-ID-VALUE" "*CLASS.ID-VALUE*" "MAKE-ID-VALUE"
"INFO-ITEM-NODE" "IS-INFO-ITEM-NODE" "*CLASS.INFO-ITEM-NODE*" "MAKE-INFO-ITEM-NODE"
"NMTOKEN-ATTR-NODE" "IS-NMTOKEN-ATTR-NODE" "*CLASS.NMTOKEN-ATTR-NODE*" "MAKE-NMTOKEN-ATTR-NODE"
"NMTOKENS-ATTR-NODE" "IS-NMTOKENS-ATTR-NODE" "*CLASS.NMTOKENS-ATTR-NODE*" "MAKE-NMTOKENS-ATTR-NODE"
"NOTATION-ATTR-NODE" "IS-NOTATION-ATTR-NODE" "*CLASS.NOTATION-ATTR-NODE*" "MAKE-NOTATION-ATTR-NODE"
"NOTATION-VALUE" "IS-NOTATION-VALUE" "*CLASS.NOTATION-VALUE*" "MAKE-NOTATION-VALUE"
"NS-NODE" "IS-NS-NODE" "*CLASS.NS-NODE*" "MAKE-NS-NODE"
"NUMBER-VALUE" "IS-NUMBER-VALUE" "*CLASS.NUMBER-VALUE*" "MAKE-NUMBER-VALUE"
"ORDINAL-NODE" "IS-ORDINAL-NODE" "*CLASS.ORDINAL-NODE*" "MAKE-ORDINAL-NODE"
"PI-NODE" "IS-PI-NODE" "*CLASS.PI-NODE*" "MAKE-PI-NODE"
"QNAME-ATTR-NODE" "IS-QNAME-ATTR-NODE" "*CLASS.QNAME-ATTR-NODE*" "MAKE-QNAME-ATTR-NODE"
"QNAME-CONTEXT" "IS-QNAME-CONTEXT" "*CLASS.QNAME-CONTEXT*" "MAKE-QNAME-CONTEXT"
"QNAME-VALUE" "IS-QNAME-VALUE" "*CLASS.QNAME-VALUE*" "MAKE-QNAME-VALUE"
"RECUR-DUR-ATTR-NODE" "IS-RECUR-DUR-ATTR-NODE" "*CLASS.RECUR-DUR-ATTR-NODE*" "MAKE-RECUR-DUR-ATTR-NODE"
"RECUR-DUR-VALUE" "IS-RECUR-DUR-VALUE" "*CLASS.RECUR-DUR-VALUE*" "MAKE-RECUR-DUR-VALUE"
"REF-CHARACTER-ENTITY" "IS-REF-CHARACTER-ENTITY" "*CLASS.REF-CHARACTER-ENTITY*" "MAKE-REF-CHARACTER-ENTITY"
"REF-ENTITY" "IS-REF-ENTITY" "*CLASS.REF-ENTITY*" "MAKE-REF-ENTITY"
"REF-GENERAL-ENTITY" "IS-REF-GENERAL-ENTITY" "*CLASS.REF-GENERAL-ENTITY*" "MAKE-REF-GENERAL-ENTITY"
"REF-NODE" "IS-REF-NODE" "*CLASS.REF-NODE*" "MAKE-REF-NODE"
"REF-PARAMETER-ENTITY" "IS-REF-PARAMETER-ENTITY" "*CLASS.REF-PARAMETER-ENTITY*" "MAKE-REF-PARAMETER-ENTITY"
"STRING-ATTR-NODE" "IS-STRING-ATTR-NODE" "*CLASS.STRING-ATTR-NODE*" "MAKE-STRING-ATTR-NODE"
"STRING-VALUE" "IS-STRING-VALUE" "*CLASS.STRING-VALUE*" "MAKE-STRING-VALUE"
"TIME-ATTR-NODE" "IS-TIME-ATTR-NODE" "*CLASS.TIME-ATTR-NODE*" "MAKE-TIME-ATTR-NODE"
"TIME-DUR-VALUE" "IS-TIME-DUR-VALUE" "*CLASS.TIME-DUR-VALUE*" "MAKE-TIME-DUR-VALUE"
"URI-REF-ATTR-NODE" "IS-URI-REF-ATTR-NODE" "*CLASS.URI-REF-ATTR-NODE*" "MAKE-URI-REF-ATTR-NODE"
"URI-REF-VALUE" "IS-URI-REF-VALUE" "*CLASS.URI-REF-VALUE*" "MAKE-URI-REF-VALUE"
"VALUE-NODE" "IS-VALUE-NODE" "*CLASS.VALUE-NODE*" "MAKE-VALUE-NODE"
;; accessors
"URI"
"CHILDREN"
"ROOT"
"VALIDATE?"
"PARENT"
"DEF"
"DOCUMENT"
"EXPAND"
"NAMESPACES"
"ATTRIBUTES"
"PROPERTIES"
"NOTATION"
"ORDINALITY"
"MODEL"
"NODE-CLASS"
"NODE-VALIDATOR"
"VALUE"
"ENCODING"
"NODES"
"PREFIX"
"TARGET"
"DEREF"
"IS-FIXED"
"IS-REQUIRED"
"IS-IMPLIED"
"IS-EPHEMERAL"
"PROTOTYPE"
"STIPULATION"
"PROPS-DEFAULTED"
"PROPS-REQUIRED"
"VERSION"
"STANDALONE"
"SYSTEM-ID"
"PUBLIC-ID"
"NAMESPACE-NAME"
"LOCAL-NAME"
;; additional accessors and abstract nodes which are not in the model
"ENTITIES"
"NOTATIONS"
"TYPES"
"ATTRIBUTES"
"PRECEDING-SIBLINGS"
"FOLLOWING-SIBLINGS"
"GENERAL-ENTITIES"
"PARAMETER-ENTITIES"
"NAMED-VALUE-NODE"
"ELEM-PROPERTY-NODE"
"ELEM-CHILD-NODE"
"DOC-CHILD-NODE"
"FUNCTION-VALUE"
"IS-FUNCTION-VALUE"
"EXPRESSION"
"CHARACTER-DATA-NODE"
"PI-NODES"
"COMMENT-NODES"
"CONTENT"
"ENTITY-INFO"
"REF-ELEM-NODE"
"REF-ELEM-PROPERTY-NODE"
"CLONE-NODE"
"LOCAL-PART"
"CHECK-CONSTRAINT"
"BIND-DEFINITION"
"COLLECT-MODEL-NAMES"
"FIRST-MODEL-NAME"
"ASSIGN-UNIVERSAL-NAMES"
"VALIDATE-CONTENT"
;; serialization interface
"WRITE-NODE"
"*NODE-LEVEL*"
"*VERBOSE-QNAMES*"
"ELEMENT-APPEND"
"ELEMENT-GET"
"ELEMENT-SET"
"EXPORT-NAMES"
"FIND-ATTRIBUTE"
"FIND-ELEMENT"
"FIND-ELEMENT-BY-ID"
"FIND-NAME"
"FIND-NAMESPACE"
"FIND-PREFIX"
"INTERN-NAME"
"INTERN-PREFIX"
"INTERN-TYPE"
"MAKE-NAME"
"MAKE-QNAME"
"NAME"
"NAMESPACE"
"CONTENT-NAME-TYPE-NAME"
"PARENT-COUNT"
"*CONSTANT-PREFIX-STRINGS*"
"*DEF-NULL-NAMESPACE-NODE*"
"*DEFAULT-NAMESPACE-ATTRIBUTE-NAME*"
"*DEFAULT-PREFIX-NAME*"
"*DEFAULT-NAMESPACES*"
"*DEFAULT-NAMESPACE*"
"*DOCUMENT*"
"*ELEMENT-COUNT*"
"*EMPTY-NAME*"
"*GENERATED-NS-BINDINGS*"
"*INPUT-SOURCE*"
"*MIXED-NAME*"
"*NAMESPACE-BINDINGS*"
"*NAMESPACE-DICTIONARY*"
"*NAMESPACE-MODE*"
"*NAMESPACE*"
"*NULL-NAME*"
"*NULL-NAMESPACE*"
"*NULL-NAMESPACE-NODE*"
"*OUTPUT-DESTINATION*"
"*UNBINDABLE-PREFIX-STRINGS*"
"*XHTML-NAMESPACE*"
"*XMLNS-NAMESPACE*"
"*XML-NAMESPACE*"
"*XML-PREFIX-NAMESTRING*"
"*XMLNS-PREFIX-NAMESTRING*"
"*WILD-NAMESPACE*"
"*WILD-NAMESTRING*"
"*WILD-PREFIX*"
"*XML-NAMESPACE-ATTRIBUTE-NAME*"
"*XML-NAMESPACE-NODE*"
"*XMLNS-NAMESPACE-ATTRIBUTE-NAME*"
"*XMLNS-NAMESPACE-NODE*"
"*XSD-NAMESPACE*"
"PREFIX-VALUE"
"NAMESPACE-PREFIX"
;; qualified name resolution
"*QNAME-EXTENT*"
"*DEF-TYPE-ID-QNAME-CONTEXTS*"
"*DEF-TYPE-MODEL-QNAME-CONTEXTS*"
"*DEF-ATTR-QNAME-CONTEXTS*"
"NEW-QNAME-EXTENT"
"QNAME-EXTENT"
"QNAME-EXTENT-EQUAL"
"*DISTINGUISH-QNAME-HOMOGRAPHS*"
"*CONFLATE-QNAME-SYNONYMS*"
"ACCUMULATE-QNAMES"
"ABSTRACT-NAME"
"UNAME"
"QNAME"
"VALUE-STRING"
"VALUE-NUMBER"
"VALUE-BOOLEAN"
"FIND-DEF-PARAMETER-ENTITY"
"FIND-DEF-GENERAL-ENTITY"
"FIND-DEF-ELEM-TYPE"
"FIND-DEF-NOTATION"
"IS-NAMECHARDATA"
"IS-NCNAME"
;; utility functions
*SPECIALIZE-ELEM-NODE*
*SPECIALIZE-ATTR-NODE*
"*TOKEN-PACKAGE*"
"*WILD-NAME*"
"*WILD-UNAME*"
"*LANG-NAME*"
"!-reader"
"WALK-NODE"
"XML-ERROR"
"XML-EOF-ERROR"
"DOCUMENT-MODEL-ERROR"
"INTERNAL-XML-ERROR"
"VALIDITY-CERROR"
"VALIDITY-CONDITION"
"NAMESPACE-ERROR"
"WELLFORMEDNESS-ERROR"
"WELLFORMEDNESS-CERROR"
"SIMPLE-XML-ERROR"
"INCOMPLETE-PARSE"
"PRINT-QNAME"
"PRINT-NS-NODE"
"COLLECT-NODE-BY-TYPE"
"MAP-NODE-BY-TYPE"
"COLLECT-ATTRIBUTE-DECLARATIONS"
"COLLECT-ATTRIBUTES"
"COLLECT-COMMENTS"
"COLLECT-COMMENTS-AND-PIS"
"COLLECT-DECLARATIONS"
"COLLECT-ELEMENT-DECLARATIONS"
"COLLECT-ELEMENT-PROPERTIES"
"COLLECT-ELEMENTS"
"COLLECT-GENERAL-ENTITIES"
"COLLECT-NAMESPACES"
"COLLECT-NOTATIONS"
"COLLECT-PARAMETER-ENTITIES"
"COLLECT-PIS"
"UNAME-EQUAL"
"QNAME-EQUAL"
"NODE-EQUAL"
"MAKE-DOCUMENT-NAMESPACE-BINDINGS"
"content-model"
"|-content"
"?-content"
"*-content"
"bounded-content"
"MIXED-content"
"+-content"
"content"
",-content"
"content-name"
"type-name"
"mixed-atn"
"element-atn"
;; character classes
"XML-CHAR?"
"XML-SPACE?"
"XML-IDEOGRAPHIC?"
"XML-BASECHAR?"
"XML-LETTER?"
"XML-DIGIT?"
"XML-COMBININGCHAR?"
"XML-EXTENDER?"
"XML-NAMECHAR?"
"XML-INITIAL-NAMECHAR?"
"XML-PUBIDCHAR?"
"XML-MARKUPCHAR?"
"XML-LATINALPHACHAR?"
"XML-LATINCHAR?"
"XML-LANGUAGEIDCHAR?"
"XML-VERSIONNUMCHAR?"
"XML-MODEL-OP-CHAR?"
"XML-SUCCESSOR-EOLCHAR?"
"XML-INITIAL-EOLCHAR?"
;; graphs
"WRITE-NODE-GRAPH"
"ENCODE-NODE-GRAPH"
"NODE-GRAPH-PROPERTIES"
"NODE-LINK-PROPERTIES"
;; 0.950 compatibility
:annotation-model
:constant-prefix-p
:direct-annotation-model
:condition-name
:condition-namespace
:document
:document-element
:element-definition
:element-p
:general-entity-definition
:id-attr-node-p
:namespace-declaration
:namespace-equal
:parameter-entity-definition
:type-definition
:unbindable-prefix-p
:with-namespaces
:default-namespace
:*default-prefix-string*
:local-part-equal
:valid
:namespace-printname
".//*"
".//"
"./@"
"./@-STRING"
"./@-VALUE"
"./"
"./-STRING"
"./-VALUE"
))
(defPackage "XML-PARSER"
(:nicknames "XMLP"
:de.setf.xml
:de.setf.xml.interface
:de.setf.xml.codec.implementation
:de.setf.xml.process.implementation)
(:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XQDM" "XUTILS")
#+CCL (:shadowing-import-from "XQDM" "TARGET")
(:export
"*CONSTRUCTION-CONTEXT*"
"*SPECIALIZE-ELEM-NODE*"
"*SPECIALIZE-ATTR-NODE*"
"AttCharData-Constructor"
"Attribute-Constructor"
"CALL-WITH-NAME-PROPERTIES"
"CharData-Constructor"
"CDataCharData-Constructor"
"Comment-Constructor"
"CONSTRUCT-ATTRIBUTE-NAME"
"CONSTRUCT-ATTRIBUTE-PLIST"
"CONSTRUCT-CONSTRUCTION-CONTEXT"
"CONSTRUCT-CONTENT-SEQUENCE"
"CONSTRUCT-ELEM-PROPERTY-NODE"
"CONSTRUCT-ELEMENT-NAME"
"CONSTRUCT-ELEMENT-NODE"
"CONSTRUCT-NS-NODE"
"CONSTRUCT-STRING-ATTR-NODE"
"Content-Constructor"
"ContentSequence-Constructor"
;; the constructor method for attribute default values remains unexported
;; until specialization is implemented for the DTD as a whole...
;; "DefaultAttCharData-Constructor"
"DEFPIFUNCTION"
"Document-Constructor"
"DOCUMENT-PARSER"
"Element-Constructor"
"ENCODE-CHAR"
"ENCODE-FORMAT"
"ENCODE-NODE"
"ENCODE-STRING"
"ENCODE-NEWLINE"
"ExtParsedEnt-Constructor"
"Pi-Constructor"
"PI-FUNCTION"
"PiCharData-Constructor"
;; "MAKE-NCNAME"
;; "MAKE-UNAME"
"PARSE-EXTERNAL-ENTITY-DATA"
"PARSE-EXTERNAL-SOURCE"
"PARSE-EXTERNAL-SUBSET"
"PARSE-EXTERNAL-GENERAL-ENTITY"
"READ-EXTERNAL-ENTITY-DATA"
"STag-Constructor"
"WRITE-NODE"
"WRITER-STREAM"
"XML"
"*XML-WRITER-STREAM*"
"WITH-XML-WRITER"
;; 0.950 compatibility
:prefix-namespace
)
)
(defPackage "XML-PATH"
(:nicknames "XP")
(:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XQDM" "XUTILS")
;; the term 'step' is central to the standard so it is shadowed rather
;; than using an alternative.
(:shadow "STEP")
#+CCL (:shadowing-import-from "XQDM" "TARGET")
(:EXPORT
"PATH" "STEP" "CONTEXT"
"PATH-ELEMENT" "STEP-ELEMENT" "STEP-GENERATOR" "STEP-FILTER"
"ENUMERATING-STEP-GENERATOR" "LIST-GENERATOR" "AXIS-GENERATOR"
"MAP-NODES" "NAME-TEST" "NODE-SET" "NODE-TEST" "TYPE-TEST"
"TERM" "IS-ABSOLUTE" "STEPS" "GENERATOR"
"TEST" "PREDICATES" "SOURCE" "PREFIX" "LOCAL-PART"
"STEP-GENERATOR-FUNCTION" "STEP-PREDICATE-FUNCTION"
"LITERAL"
"NODE" "LOCATION" "SIZE" "BINDINGS" "VARIABLES" "FUNCTIONS" "NAMESPACES"
"EXPRESSION"
"*CLASS.PATH*"
"*CLASS.STEP*"
"*CLASS.CONTEXT*"
"*CLASS.CHILD*"
"*DOCUMENTS*"
)
)
(defPackage "XML-QUERY"
(:nicknames "XQ")
(:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XQDM" "XUTILS")
#+CCL (:shadowing-import-from "XQDM" "TARGET")
)
(defPackage "xml" (:use)
(:nicknames "http://www.w3.org/XML/1998/namespace")
(:export " " "!=" "!=" "!==" "\"" "#FIXED" "#IMPLIED" "#PCDATA" "#REQUIRED"
"$" "%" "&" "&#" "&#x" "'" "(" "()" ")" ")*" "*" "*:" "+" ","
"-" "-->" "->" "." ".." "/" "//" "/>" ":" ":=" "::" ":*" ";" "<" "<!" "<!--"
"<!ATTLIST" "<!DOCTYPE" "<!ELEMENT" "<!ENTITY" "<!NOTATION"
"<![" "<![CDATA[" "</" "<=" "<?" "<?xml" "=" "==" ">" ">=" "?" "?>"
"@" "AFTER" "ANY" "ASCENDING" "BEFORE" "CDATA" "DESCENDING" "EMPTY"
"ENTITIES" "ENTITY" "ID" "IDREF" "IDREFS" "IGNORE" "INCLUDE"
"NDATA" "NMTOKEN" "NMTOKENS" "NOT" "NOTATION" "PUBLIC" "SYSTEM"
"[" "]" "]]>" "^"
"ancestor" "ancestor-or-self" "and" "attribute"
"child" "comment"
"descendant" "descendant-or-self" "div" "document"
"encoding" "following" "following-sibling"
"id" "key" "lang"
"mixed" "mod" "namespace" "no" "node" "not" "or"
"parent" "preceding" "preceding-sibling" "processing-instruction"
"root" "self" "standalone" "text" "union" "version" "xml" "yes"
"{" "|" "}" "�"))
;;
;;
;; packages for implementing xml data modeling.
;; types from the datatype package appear in expression in the two algrbras. they are
;; exported, but not used/imported, as the customary expression uses the prefix.
;; the case distinctions distinguish grammatic meta-symbols which participate in special
;; forms from the names for functions and types, which conserve case.
;; package for xml query types
(defPackage "XML-SCHEMA-DATATYPES" (:use) (:nicknames "XSD")
(:export "TYPEP" "TYPEP-SPECIALIZED"
"IS-anyComplexType" "IS-anySimpleType" "IS-anyTreeType" "IS-anyType" "IS-anyURI"
"IS-attribute" "IS-base64Binary" "IS-boolean" "IS-byte" "IS-comment" "IS-complex"
"IS-date" "IS-dateTime"
"IS-decimal" "IS-double" "IS-duration"
"IS-element" "IS-ENTITY" "IS-ENTITIES" "IS-float"
"IS-gDay" "IS-gMonth" "IS-gMonthDay" "IS-gYear"
"IS-hexBinary" "IS-ID" "IS-IDREF" "IS-IDREFS"
"IS-int" "IS-integer" "IS-language" "IS-long"
"IS-Name" "IS-NCName" "IS-NMTOKEN" "IS-NMTOKENS"
"IS-negativeInteger" "IS-nonNegativeInteger" "IS-nonPositiveInteger" "IS-normalizedString"
"IS-NOTATION" "IS-pi" "IS-positiveInteger" "IS-scalar" "IS-short" "IS-simple"
"IS-string" "IS-time" "IS-token" "IS-UName"
"IS-unsignedByte" "IS-unsignedInt" "IS-unsignedLong" "IS-unsignedShort"
"VALIDATE-STRING" "VALIDATE-ATTRIBUTE" "VALIDATE-NAME"))
;; package for xml path "algebra" operators
(defPackage "XML-PATH-ALGEBRA" (:use) (:nicknames "XPA")
(:import-from "xml" "document")
(:intern "APPLY-DESCENDANTS-PATH" "APPLY-CHILD-PATH" "APPLY-PATH"
"APPLY-PREDICATE-PATH" "APPLY-STEP"
"EVAL" "FUNCALL" "LANGUAGE-EQUAL" "NODES" "VARIABLE"
"SYMBOL-FUNCTION" "GENSYM")
(:export
;; path components
"PATH" "STEP" "UNAME"
"ID-STEP" "KEY-STEP" "PARENT-STEP" "ROOT-STEP" "SELF-STEP" "WILD-INFERIOR-STEP"
"AXIS-GENERATOR" "LIST-GENERATOR"
"ANCESTOR" "ANCESTOR-OR-SELF" "ATTRIBUTE" "CHILD" "DESCENDANT"
"DESCENDANT-OR-SELF" "FOLLOWING" "FOLLOWING-OR-SELF" "FOLLOWING-SIBLING"
"ID" "KEY"
"NAMESPACE" "PARENT" "PRECEDING" "PRECEDING-SIBLING" "ROOT" "SELF"
"NAME-TEST" "@NAME-TEST" "TYPE-TEST" "TYPE-NAME-TEST"
"PI-TEST" "COMMENT-TEST" "TEXT-TEST"
"PREDICATE"
;; state variables
"*CONTEXT-NODE*" "*POSITION*" "*COUNT*"
;; library functions
"and"
"boolean"
"ceiling" "contains" "count"
"document"
"false" "floor"
"id"
"last" "local-name" "lang"
"mod"
"name" "namespace-uri" "normalize-space" "not" "number"
"or"
"position"
"round"
"starts-with" "string" "substring"
"substring-after" "substring-before"
"string-length" "sum"
"translate" "true"
"union"
"+" "-" "*" "/" "<" "<=" ">" ">=" "=" "!="
"NaN" "0+" "0-" "infinity+" "infinity-"
))
;; package for xml query algebra operators
(defPackage "XML-QUERY-ALGEBRA" (:use) (:nicknames "XQA")
(:import-from "XPA"
"and"
"boolean"
"ceiling" "contains" "count"
"document"
"false" "floor"
"id"
"last" "local-name" "lang"
"mod"
"name" "namespace-uri" "normalize-space" "not" "number"
"or"
"position"
"round"
"starts-with" "string" "substring"
"substring-after" "substring-before"
"string-length" "sum"
"translate" "true"
"union"
;; these are not imported "<" "<=" ">" ">=" "="
;; as the comparison differs
"+" "-" "*" "/" "!="
"NaN" "0+" "0-" "infinity+" "infinity-"
"GENSYM")
(:EXPORT "IF" "LET" "ELSE" "FOR" "MATCH" "CASE" "WHERE"
"TYPE" "FUN" "QUERY"
"AND" "OR" "NOT" "DIV" "MOD" "SCHEMA"
"+" "-" "*" "<" "<=" ">" ">=" "=" "==" "!=" "!=="
"//" "/" "." "|"
"DEFUN"
"ATTRIBUTE" "ELEMENT"
"MAKE-NCNAME" "MAKE-TNAME" "MAKE-UNAME"
"sequence" "UNION" "DIFFERENCE" "INTERSECTION" "SORT"
"ERROR" "INSTANCEOF" "BEFORE" "AFTER"
"TYPEP" "TYPE" "SORT"
"TYPE-REF" "ID-TEST" "TYPEP" "RANGE-TEST"
;; xpath algebra symbols
"and"
"boolean"
"cdata" "ceiling" "contains" "count"
"document"
"false" "floor"
"id"
"last" "local-name" "lang"
"mod"
"name" "namespace-uri" "normalize-space" "not" "number"
"or"
"position"
"round"
"starts-with" "string" "substring"
"substring-after" "substring-before"
"string-length" "sum"
"translate" "true"
"union"
"NaN" "0+" "0-" "infinity+" "infinity-"
;; xml query algebra specific
"avg"
"bagtolist"
"data" "difference" "distinct_nodes" "distinct_value"
"comment" "Comment" "deref"
"except"
"index" "intersection"
"listtobag" "localname"
"max" "min"
"namespace" "nodes"
"parent" "processing_instruction"
"ref"
"sequence" "sort"
"target"
"value"
"empty"
"==" ))
(defPackage "$" (:use))
(defpackage "XML-QUERY-LANGUAGE" (:use) (:nicknames "XQL")
(:import-from "XPA"
"and"
"boolean"
"ceiling" "contains" "count"
"document"
"false" "floor"
"id"
"last" "local-name" "lang"
"mod"
"name" "namespace-uri" "normalize-space" "not" "number"
"or"
"position"
"round"
"starts-with" "string" "substring"
"substring-after" "substring-before"
"string-length" "sum"
"translate" "true"
"union"
"+" "-" "*" "/" "!="
"NaN" "0+" "0-" "infinity+" "infinity-")
(:import-from "XQA"
"<" "<=" ">" ">=" "=")
(:export "ELEMENT" "ATTRIBUTE" "CAST" "TREAT" "INTERSECT" "EXCEPT"
"INSTANCEOF" "SOME" "EVERY" "FUNCTION"
"FUNCALL" "NAMESPACE-DECL" "QNAME" "SCHEMA-DECL"
"ID-PATH" "ATTRIBUTE-PATH" "TYPE-PATH" "ELEMENT-PATH"
"RANGE" "/" "//" "*" "STEP" "TYPE"
;; xpath algebra symbols
"and"
"boolean"
"ceiling" "contains" "count"
"document"
"false" "floor"
"id"
"last" "local-name" "lang"
"mod"
"name" "namespace-uri" "normalize-space" "not" "number"
"or"
"position"
"round"
"starts-with" "string" "substring"
"substring-after" "substring-before"
"string-length" "sum"
"translate" "true"
"union"
"+" "-" "*" "/" "<" "<=" ">" ">=" "=" "!="
"NaN" "0+" "0-" "infinity+" "infinity-"
;; xquery language library
"comment" "date" "distinct"
"empty" "equal" "filter" "last"
"name" "number" "pi" "union"))
;; additions for cl-http tokenizer
#-CL-HTTP
(defpackage "WWW-UTILS"
(:use common-lisp)
(:intern "WITH-FAST-ARRAY-REFERENCES" "MAKE-LOCK" "WITH-LOCK-HELD"))
#-CL-HTTP
(defpackage tk1
(:use common-lisp)
(:import-from "WWW-UTILS" "WITH-FAST-ARRAY-REFERENCES" "MAKE-LOCK" "WITH-LOCK-HELD")
(:export
"*DEFAULT-TOKENIZER-SIZE*"
"CLEAR-TOKENIZER"
"CREATE-TOKENIZER"
"DEFINE-TOKENIZER"
"DESCRIBE-TOKENIZER"
"FIND-TOKENIZER-NAMED"
"GET-TOKEN"
"INSERT-TOKEN"
"MAP-TOKENS"
"REHASH-TOKENIZER"
"REMOVE-TOKEN"
"TOKENIZE"
"UNDEFINE-TOKENIZER"))
#-CL-HTTP
(defPackage "HTTP"
(:export "*STANDARD-CHARACTER-TYPE*"))
:EOF
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*-
+
+#|
+<DOCUMENTATION>
+ nb. see XQueryDataModel:XQDM-classes for exports for class predicate and constructors
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+ href='file://xml/sysdcl.lisp' /> <CHRONOLOGY>
+ <DELTA DATE='20010507'>incorporated character class exports</DELTA>
+ <DELTA DATE='20010617'>moved parsetable to XML-UTILS</DELTA>
+ <DELTA DATE='20010621'>exported xml serialization iterface</DELTA>
+ <DELTA DATE='20010622'>parameters for reader adjustments for null symbol names</DELTA>
+ <DELTA DATE='20010624'>node graph interface</DELTA>
+ <DELTA DATE='20010702'><code>DATA-URL</code>; differentiated qname contexts</DELTA>
+ <DELTA DATE='20010714'>factored namespaces out</DELTA>
+ <DELTA DATE='20010718'>xmlparser package renamed to XMLP</DELTA>
+ <DELTA DATE='20010808'>added '$' package for XQL variables</DELTA>
+ <DELTA DATE='20010816'>additions for schema types</DELTA>
+ <DELTA DATE='20010902'>www-utils and tk1 package for cl-http tokenizer</DELTA>
+ <DELTA DATE='20030320'>added 0.950 package nicknmes inorder to use its condition implementation</DELTA>
+ </CHRONOLOGY>
+ </DOCUMENTATION>
+|#
+
+(in-package "CL-USER")
+
+(defPackage "BNF-PARSER"
+ (:nicknames "BNFP")
+ (:use :common-lisp #+:ccl :ccl #+lispworks :harlequin-common-lisp :de.setf.utility.conditions )
+ (:shadow "SYMBOL")
+ #+Allegro (:import-from "EXCL" "WITHOUT-INTERRUPTS")
+ #+(and Allegro (version>= 6 0)) (:import-from "MOP" "CLASS-PRECEDENCE-LIST")
+ #+(and Allegro (version< 6 0)) (:import-from "CLOS" "CLASS-PRECEDENCE-LIST")
+ #+Genera (:import-from "CLOS-INTERNALS" "CLASS-PRECEDENCE-LIST" "FUNCALLABLE-STANDARD-CLASS" "VALIDATE-SUPERCLASS")
+ #+Genera(:import-from "SCL" "WITHOUT-INTERRUPTS")
+ #+Genera(:shadowing-import-from "SI" "STREAM")
+ #+lispworks (:import-from :lispworks :without-interrupts)
+ #+CMU (:import-from "SYSTEM" "WITHOUT-INTERRUPTS")
+ #+PCL (:shadowing-import-from "PCL" "CLASS-PRECEDENCE-LIST"
+ "FUNCALLABLE-STANDARD-CLASS"
+ "VALIDATE-SUPERCLASS"
+ "STANDARD-CLASS" "BUILT-IN-CLASS"
+ "FIND-CLASS" "CLASS-NAME" "CLASS-OF")
+ #+SBCL (:import-from "SB-SYS" "WITHOUT-INTERRUPTS")
+ #+sbcl (:shadowing-import-from "SB-PCL" "CLASS-PRECEDENCE-LIST"
+ "FUNCALLABLE-STANDARD-CLASS"
+ "VALIDATE-SUPERCLASS"
+ "STANDARD-CLASS" "BUILT-IN-CLASS"
+ "FIND-CLASS" "CLASS-NAME" "CLASS-OF")
+ (:export
+ "*ATN-CLASS"
+ "*ATN-LEVEL"
+ "*ATN-NET"
+ "*ATN-NODE"
+ "*ATN-PROPERTIES"
+ "*ATN-REGISTER-WORDS"
+ "*ATN-SAVE-DEFINITIONS*"
+ "*ATN-STACK"
+ "*ATN-STRUCTURE*"
+ "*ATN-TERM*"
+ "*ATN-TERM?*"
+ "*ATN-TOKEN-PACKAGE*"
+ "*ATN-TRACE*"
+ "*ATN-TRACE-NETS*"
+ "*ATN-WFST"
+ "*CLASS.ATN*"
+ "*CLASS.ATN-ALTERNATIVE-CATEGORY*"
+ "*CLASS.ATN-BUILTIN-PREDICATE-CATEGORY*"
+ "*CLASS.ATN-CELL-CATEGORY*"
+ "*CLASS.ATN-COMPLEMENT-CATEGORY*"
+ "*CLASS.ATN-CONJUNCTION*"
+ "*CLASS.ATN-DERIVED-CATEGORY*"
+ "*CLASS.ATN-LEXEM*"
+ "*CLASS.ATN-LEXICON*"
+ "*CLASS.ATN-NEGATED-ALTERNATIVES*"
+ "*CLASS.ATN-NODE*"
+ "*CLASS.ATN-PRIMITIVE-CATEGORY*"
+ "*CLASS.ATN-UNDECLARED-CATEGORY*"
+ "*CLASS.CAT-ATN-EDGE*"
+ "*CLASS.CELL-ATN-EDGE*"
+ "*CLASS.JUMP-ATN-EDGE*"
+ "*CLASS.OR-ATN-EDGE*"
+ "*CLASS.POP-ATN-EDGE*"
+ "*CLASS.PUSH-ATN-EDGE*"
+ "*CLASS.TEST-ATN-EDGE*"
+ "*CLASS.WORD-ATN-EDGE*"
+ "*SOURCE-RECORDING*"
+ :*terminal-parser-error-action*
+ "ATN"
+ "ATN-ALTERNATIVE-CATEGORY"
+ "ATN-BINDINGS"
+ "ATN-BUILTIN-PREDICATE-CATEGORY"
+ "ATN-CELL-CATEGORY"
+ "ATN-COMPLEMENT-CATEGORY"
+ "ATN-CONJUNCTION"
+ "ATN-CONSTRUCTOR-SPECIALIZER"
+ "ATN-CONTINUE-ACTIONS"
+ "ATN-DERIVED-CATEGORY"
+ "ATN-FAIL-ACTIONS"
+ "ATN-FINALLY"
+ "ATN-INITIAL-ACTIONS"
+ "ATN-INPUT"
+ "ATN-LEXEM"
+ "ATN-LEXICON"
+ "ATN-NAME"
+ "ATN-NEGATED-ALTERNATIVES"
+ "ATN-NODE"
+ "ATN-PRIMITIVE-CATEGORY"
+ "ATN-PROCEDURE-CALL"
+ "ATN-RECURSION"
+ "ATN-REDUCE-ITEM"
+ "ATN-REDUCE-STRUCTURE"
+ "ATN-SEQUENCE-INPUT"
+ "ATN-STACK"
+ "ATN-SUCCEED-ACTIONS"
+ "ATN-TERM-CARDINALITY"
+ "ATN-TERM-NAMES"
+ "ATN-UNDECLARED-CATEGORY"
+ "BNF-TO-REGEX-ATN"
+ "CALL-WITH-PARSED-ALIST"
+ "CALL-WITH-PARSED-TERMS"
+ "CAT-ATN-EDGE"
+ "CELL-ATN-EDGE"
+ "COMPILE-ATN-SYSTEM"
+ "CONSTRUCTOR-SPECIALIZERS"
+ "CONTINUABLE-PARSER-ERROR"
+ "FIND-PARSED-TERM"
+ "INFERENCE-SYSTEM"
+ "INFERENCE-UNIT"
+ "INPUT.IS-AT-END"
+ "INPUT.ITEM"
+ "INPUT.LAST-ITEM"
+ "INPUT.LENGTH"
+ "INPUT.PEEK-ITEM"
+ "INPUT.REPLACE-ITEM"
+ "IS-ATN-TRACE"
+ "IS-REDUCTION-ENABLED"
+ "JUMP-ATN-EDGE"
+ "MAKE-LISP-FORM"
+ "MAKE-LISP-SUBFORM"
+ "MAKE-LISP-TEST-FORM"
+ "MATCH-REGEX"
+ "NTH-PARSE-RESULT"
+ "OR-ATN-EDGE"
+ "PARSER-EOF-ERROR"
+ "PARSER-ERROR"
+ "PARSE-RESULT"
+ "POP-ATN-EDGE"
+ "PPRINT-ATN"
+ "PUSH-ATN-EDGE"
+ "REGULAR-EXPRESSION-TO-REGEX-ATN"
+ "RULE"
+ "RULE-DOCUMENTATION"
+ "RULE-NAME"
+ "RULE-SOURCES"
+ "SORT-PARSE-RESULTS"
+ "SYSTEM"
+ "SYSTEM-DOCUMENTATION"
+ "SYSTEM-NAME"
+ "SYSTEM-PLIST"
+ "TERMINAL-PARSER-ERROR"
+ "TEST-ATN-EDGE"
+ "WITH-PARSED-ALIST"
+ "WITH-PARSED-PLIST"
+ "WITH-PARSED-TERM"
+ "WORD-ATN-EDGE"
+
+ ;; for parse states
+ :condition-parse-state
+ :condition-action
+ :parse-state
+ :parse-state-condition
+ :parse-state-source
+ :parse-state-term
+ :parse-state-non-terminal
+ :parse-state-stack
+ :parse-state-active-p
+ :print-parse-state
+ :make-parse-state
+ ))
+
+(defPackage "XML-UTILS"
+ (:nicknames "XUTILS" :de.setf.xml.base.implementation
+ :de.setf.xml.conditions)
+ (:use :common-lisp #+ccl :ccl
+ :de.setf.utility.conditions)
+ #+CCL (:import-from "CCL" "STREAM-POSITION")
+ #+CL-HTTP (:import-from "URL" "URI" "URL" "PARSE-URL" "INTERN-URL"
+ "HTTP-URL" "FILE-URL" "NAME-STRING"
+ "PATH" "HOST" "HOST-STRING" "PORT" "OBJECT" "EXTENSION"
+ "TRANSLATED-PATHNAME"
+ ;; for the file-url function
+ "DIRECTORY-NAME-STRING" "WITH-VALUE-CACHED"
+ "WRITE-SCHEME-PREFIX" "WRITE-HOST-PORT-STRING" "WRITE-PATH")
+ #+CL-HTTP (:import-from "HTTP" "MERGE-URL")
+ #+ALLEGRO (:import-from "EXCL" "WITHOUT-INTERRUPTS")
+ #+lispworks (:import-from :lispworks :without-interrupts)
+ #+CMU (:import-from "SYSTEM" "WITHOUT-INTERRUPTS")
+ #+PCL (:shadowing-import-from "PCL" "CLASS-PRECEDENCE-LIST"
+ "FUNCALLABLE-STANDARD-CLASS"
+ "VALIDATE-SUPERCLASS" "STANDARD-CLASS"
+ "BUILT-IN-CLASS" "FIND-CLASS"
+ "CLASS-NAME" "CLASS-OF")
+ #+SBCL (:import-from "SB-SYS" "WITHOUT-INTERRUPTS")
+ #+sbcl (:shadowing-import-from "SB-PCL" "CLASS-PRECEDENCE-LIST"
+ "FUNCALLABLE-STANDARD-CLASS"
+ "VALIDATE-SUPERCLASS" "STANDARD-CLASS"
+ "BUILT-IN-CLASS" "FIND-CLASS"
+ "CLASS-NAME" "CLASS-OF")
+ #+digitool
+ (:import-from :ccl
+ :stream-reader
+ :stream-writer
+ :stream-column)
+ (:import-from :de.setf.utility.test
+ :deftest
+ :deftests
+ :execute-tests)
+ (:EXPORT
+ :deftest
+ :deftests
+ :execute-tests
+ "*ENCODING-MAP*"
+ "*PARSETABLE*"
+ "*TOKEN-PACKAGE*"
+ "*XML-BASE*"
+ "*XML-VERBOSE*"
+ "<-CHAR-CODE-LIMIT"
+ "CANONICAL-ENCODING"
+ "CHECKED-CODE-CHAR"
+ "CLEAR-PARSETABLE"
+ "CLEAR-PARSETABLES"
+ "COMPUTE-PARSER-MACROS"
+ "COMPUTE-TOKEN-READER"
+ "COPY-PARSETABLE"
+ "DATA-URL"
+ "DEFALTERNATIVECONSTRUCTOR"
+ "DEFCONSTANTCONSTRUCTOR"
+ "DEFCONSTRUCTOR"
+ "DEFCONSTRUCTORMETHOD"
+ "DEFIDENTITYCONSTRUCTOR"
+ "DEFLITERALCONSTRUCTOR"
+ "DEFNULLCONSTRUCTOR"
+ "DEFPARSETABLE"
+ "DEFTOKEN"
+ "DEFTOKENCONSTRUCTOR"
+ "DEFTOKENCONSTRUCTORS"
+ "DEFTOKENS"
+ "EXPORT-NAME"
+ "FILE-URL"
+ "FILE-URL-PATHNAME"
+ "HTTP-URL"
+ "MAKE-DATA-URL"
+ "MAKE-URI"
+ "MERGE-URIS"
+ "NOTE-newline-200101314"
+ :object
+ "PARSER-MACRO"
+ "PARSETABLE"
+ "PATHNAME-FILE-URL"
+ "REC-xml-19980210.End-of-Line Handling"
+ "REC-xml-19980210.PEs in Internal Subset"
+ "REC-xml-19980210.Validate Attribute Defaults"
+ "REC-xml-names-19990114"
+ "REC-xml-names-19990114.NSC: Prefix Immutable"
+ "REC-xml-names-19990114.VC: Attribute Declared"
+ "RESOLVE-ENTITY-IDENTIFIERS"
+ "SPLIT-SEQ"
+ "SPLIT-STRING"
+ "STREAM-POSITION"
+ "STREAM-STATE"
+ "TABLE.MACROS"
+ "TABLE.NAME"
+ "TABLE.PROPERTIES"
+ "URI"
+ "URI-NAMESTRING"
+ "URL"
+ "URL-DATA"
+ "URN"
+ "VECTOR-INPUT-STREAM"
+ "WITH-DATA-STREAM"
+ "WITH-FILE-STREAM"
+ "WITH-HTTP-STREAM"
+ "WITH-PARSETABLE"
+ "WITHOUT-INTERRUPTS"
+ "STREAM-COLUMN"
+ "STREAM-READER"
+ "STREAM-WRITER"
+ :check-constraint
+ :coerce-to-generic-function
+ :condition-continue-format-arguments
+ :condition-continue-format-control
+ :continuable-error
+ :continue-format-arguments
+ :continue-format-control
+ :defexception
+ :initialize-condition
+ :internal-xml-error
+ :make-initialized-condition
+ :report-condition
+ :report-condition
+ :simple-continuable-condition
+ :xml-condition
+ :xml-error
+ :xml-warn
+ :xml-warning
+ :|VC: ID|
+ :|VC: Name Token|
+ :|VC: Entity Name|
+ :|VC: Notation Attributes|
+ :|VC: Enumeration|
+ :|VC: Element Content|
+ :|VC: No Duplicate Tokens|
+ :|VC: No Duplicate Types|
+ :|NSC: Prefix Immutable|
+ :|WFC: Legal Character|
+ ))
+
+
+(defPackage "XML-QUERY-DATA-MODEL"
+ (:nicknames "XQDM"
+ :DE.SETF.XML.NAMES.IMPLEMENTATION
+ :DE.SETF.XML.NODE.IMPLEMENTATION
+ :DE.SETF.XML.MODEL
+ :DE.SETF.XML.MODEL.IMPLEMENTATION)
+ (:shadowing-import-from "BNFP" "PARSE-ERROR")
+ #+LISPWORKS
+ (:import-from "HCL" "VALIDATE-SUPERCLASS")
+ (:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XUTILS")
+ #+CCL (:shadow "TARGET")
+ #+PCL (:shadowing-import-from "PCL" "CLASS-PRECEDENCE-LIST"
+ "FUNCALLABLE-STANDARD-CLASS"
+ "VALIDATE-SUPERCLASS" "STANDARD-CLASS"
+ "BUILT-IN-CLASS" "FIND-CLASS"
+ "CLASS-NAME" "CLASS-OF"
+ "STRUCTURE-CLASS")
+ #+sbcl (:shadowing-import-from "SB-PCL" "CLASS-PRECEDENCE-LIST"
+ "FUNCALLABLE-STANDARD-CLASS"
+ "VALIDATE-SUPERCLASS" "STANDARD-CLASS"
+ "BUILT-IN-CLASS" "FIND-CLASS"
+ "CLASS-NAME" "CLASS-OF")
+ (:export
+ ;; the defTypePredicate macro exports for classes and predicate names
+ ;; the defException macro exports exception class names
+
+ "ABSTRACT-CLASS"
+ "ABSTRACT-NODE"
+ "NAMED-NODE"
+ "UNAMED-NODE"
+ "NCNAMED-NODE"
+ "TYPED-NODE"
+ "DOCUMENT-SCOPED-NODE"
+ "ORDINAL-NODE"
+ "ENTITY-DELEGATE"
+ "DOC-NODE-INTERFACE"
+ "ELEM-NODE-INTERFACE"
+ "ELEM-PROPERTY-NODE-INTERFACE"
+
+ ;; model classes: all classes export the symbol and a predicate
+ ;; concrete classes have an instantiation function and parameter
+ ;; see defTypePredicate for generation
+ "ABSTRACT-ATTR-NODE" "IS-ABSTRACT-ATTR-NODE"
+ "ABSTRACT-DEF-NODE" "IS-ABSTRACT-DEF-NODE"
+ "ABSTRACT-DEF-TYPE" "IS-ABSTRACT-DEF-TYPE"
+ "ABSTRACT-ELEM-NODE" "IS-ABSTRACT-ELEM-NODE"
+ "ABSTRACT-ELEM-PROPERTY-NODE" "IS-ABSTRACT-ELEM-PROPERTY-NODE"
+ "ABSTRACT-NS-NODE" "IS-ABSTRACT-NS-NODE"
+ "ABSTRACT-TOP-LEVEL-DEF-NODE" "IS-ABSTRACT-TOP-LEVEL-DEF-NODE"
+ "ATTR-CHILD-NODE" "IS-ATTR-CHILD-NODE" "*CLASS.ATTR-CHILD-NODE*" "MAKE-ATTR-CHILD-NODE"
+ "ATTR-NODE" "IS-ATTR-NODE" "*CLASS.ATTR-NODE*" "MAKE-ATTR-NODE"
+ "BINARY-VALUE" "IS-BINARY-VALUE" "*CLASS.BINARY-VALUE*" "MAKE-BINARY-VALUE"
+ "BOOL-VALUE" "IS-BOOL-VALUE" "*CLASS.BOOL-VALUE*" "MAKE-BOOL-VALUE"
+ "CHARACTER-DATA-NODE" "IS-CHARACTER-DATA-NODE" "*CLASS.CHARACTER-DATA-NODE*" "MAKE-CHARACTER-DATA-NODE"
+ "COMMENT-NODE" "IS-COMMENT-NODE" "*CLASS.COMMENT-NODE*" "MAKE-COMMENT-NODE"
+ "CONDITIONAL-SECTION" "IS-CONDITIONAL-SECTION" "*CLASS.CONDITIONAL-SECTION*" "MAKE-CONDITIONAL-SECTION"
+ "DECIMAL-ATTR-NODE" "IS-DECIMAL-ATTR-NODE" "*CLASS.DECIMAL-ATTR-NODE*" "MAKE-DECIMAL-ATTR-NODE"
+ "DECIMAL-VALUE" "IS-DECIMAL-VALUE" "*CLASS.DECIMAL-VALUE*" "MAKE-DECIMAL-VALUE"
+ "DEF-ATTR" "IS-DEF-ATTR" "*CLASS.DEF-ATTR*" "MAKE-DEF-ATTR"
+ "DEF-ELEM-PROPERTY-TYPE" "IS-DEF-ELEM-PROPERTY-TYPE" "*CLASS.DEF-ELEM-PROPERTY-TYPE*" "MAKE-DEF-ELEM-PROPERTY-TYPE"
+ "DEF-ELEM-TYPE" "IS-DEF-ELEM-TYPE" "*CLASS.DEF-ELEM-TYPE*" "MAKE-DEF-ELEM-TYPE"
+ "DEF-ENTITY" "IS-DEF-ENTITY" "*CLASS.DEF-ENTITY*" "MAKE-DEF-ENTITY"
+ "DEF-EXTERNAL-ENTITY" "IS-DEF-EXTERNAL-ENTITY" "*CLASS.DEF-EXTERNAL-ENTITY*" "MAKE-DEF-EXTERNAL-ENTITY"
+ "DEF-EXTERNAL-GENERAL-ENTITY" "IS-DEF-EXTERNAL-GENERAL-ENTITY" "*CLASS.DEF-EXTERNAL-GENERAL-ENTITY*" "MAKE-DEF-EXTERNAL-GENERAL-ENTITY"
+ "DEF-EXTERNAL-PARAMETER-ENTITY" "IS-DEF-EXTERNAL-PARAMETER-ENTITY" "*CLASS.DEF-EXTERNAL-PARAMETER-ENTITY*" "MAKE-DEF-EXTERNAL-PARAMETER-ENTITY"
+ "DEF-GENERAL-ENTITY" "IS-DEF-GENERAL-ENTITY" "*CLASS.DEF-GENERAL-ENTITY*" "MAKE-DEF-GENERAL-ENTITY"
+ "DEF-INTERNAL-ENTITY" "IS-DEF-INTERNAL-ENTITY" "*CLASS.DEF-INTERNAL-ENTITY*" "MAKE-DEF-INTERNAL-ENTITY"
+ "DEF-INTERNAL-GENERAL-ENTITY" "IS-DEF-INTERNAL-GENERAL-ENTITY" "*CLASS.DEF-INTERNAL-GENERAL-ENTITY*" "MAKE-DEF-INTERNAL-GENERAL-ENTITY"
+ "DEF-INTERNAL-PARAMETER-ENTITY" "IS-DEF-INTERNAL-PARAMETER-ENTITY" "*CLASS.DEF-INTERNAL-PARAMETER-ENTITY*" "MAKE-DEF-INTERNAL-PARAMETER-ENTITY"
+ "DEF-NOTATION" "IS-DEF-NOTATION" "*CLASS.DEF-NOTATION*" "MAKE-DEF-NOTATION"
+ "DEF-PARAMETER-ENTITY" "IS-DEF-PARAMETER-ENTITY" "*CLASS.DEF-PARAMETER-ENTITY*" "MAKE-DEF-PARAMETER-ENTITY"
+ "DEFNAMESPACE"
+ "DOC-CHILD-NODE" "IS-DOC-CHILD-NODE" "*CLASS.DOC-CHILD-NODE*" "MAKE-DOC-CHILD-NODE"
+ "DOC-NODE" "IS-DOC-NODE" "*CLASS.DOC-NODE*" "MAKE-DOC-NODE"
+ "DOCTYPE-CHILD-NODE" "IS-DOCTYPE-CHILD-NODE" "*CLASS.DOCTYPE-CHILD-NODE*" "MAKE-DOCTYPE-CHILD-NODE"
+ "DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE" "IS-DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE" "*CLASS.DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE*" "MAKE-DOCUMENT-TYPE-DECLARATION-INFORMATION-NODE"
+ "DOUBLE-ATTR-NODE" "IS-DOUBLE-ATTR-NODE" "*CLASS.DOUBLE-ATTR-NODE*" "MAKE-DOUBLE-ATTR-NODE"
+ "DOUBLE-VALUE" "IS-DOUBLE-VALUE" "*CLASS.DOUBLE-VALUE*" "MAKE-DOUBLE-VALUE"
+ "ELEM-CHILD-NODE" "IS-ELEM-CHILD-NODE" "*CLASS.ELEM-CHILD-NODE*" "MAKE-ELEM-CHILD-NODE"
+ "ELEM-NODE" "IS-ELEM-NODE" "*CLASS.ELEM-NODE*" "MAKE-ELEM-NODE"
+ "ELEM-PROPERTY-NODE" "IS-ELEM-PROPERTY-NODE" "*CLASS.ELEM-PROPERTY-NODE*" "MAKE-ELEM-PROPERTY-NODE"
+ "ENTITIES-ATTR-NODE" "IS-ENTITIES-ATTR-NODE" "*CLASS.ENTITIES-ATTR-NODE*" "MAKE-ENTITIES-ATTR-NODE"
+ "ENTITY-ATTR-NODE" "IS-ENTITY-ATTR-NODE" "*CLASS.ENTITY-ATTR-NODE*" "MAKE-ENTITY-ATTR-NODE"
+ "ENTITY-INFORMATION-NODE" "IS-ENTITY-INFORMATION-NODE" "*CLASS.ENTITY-INFORMATION-NODE*" "MAKE-ENTITY-INFORMATION-NODE"
+ "ENTITY-VALUE" "IS-ENTITY-VALUE" "*CLASS.ENTITY-VALUE*" "MAKE-ENTITY-VALUE"
+ "ENUMERATION-ATTR-NODE" "IS-ENUMERATION-ATTR-NODE" "*CLASS.ENUMERATION-ATTR-NODE*" "MAKE-ENUMERATION-ATTR-NODE"
+ "EXT-SUBSET-NODE" "IS-EXT-SUBSET-NODE" "*CLASS.EXT-SUBSET-NODE*" "MAKE-EXT-SUBSET-NODE"
+ "EXTERNAL-PARSED-ENTITY" "IS-EXTERNAL-PARSED-ENTITY" "*CLASS.EXTERNAL-PARSED-ENTITY*" "MAKE-EXTERNAL-PARSED-ENTITY"
+ "FLOAT-VALUE" "IS-FLOAT-VALUE" "*CLASS.FLOAT-VALUE*" "MAKE-FLOAT-VALUE"
+ "FUNCTION-VALUE" "IS-FUNCTION-VALUE" "*CLASS.FUNCTION-VALUE*" "MAKE-FUNCTION-VALUE"
+ "ID-ATTR-NODE" "IS-ID-ATTR-NODE" "*CLASS.ID-ATTR-NODE*" "MAKE-ID-ATTR-NODE"
+ "ID-REF-ATTR-NODE" "IS-ID-REF-ATTR-NODE" "*CLASS.ID-REF-ATTR-NODE*" "MAKE-ID-REF-ATTR-NODE"
+ "ID-REF-VALUE" "IS-ID-REF-VALUE" "*CLASS.ID-REF-VALUE*" "MAKE-ID-REF-VALUE"
+ "ID-REFS-ATTR-NODE" "IS-ID-REFS-ATTR-NODE" "*CLASS.ID-REFS-ATTR-NODE*" "MAKE-ID-REFS-ATTR-NODE"
+ "ID-VALUE" "IS-ID-VALUE" "*CLASS.ID-VALUE*" "MAKE-ID-VALUE"
+ "INFO-ITEM-NODE" "IS-INFO-ITEM-NODE" "*CLASS.INFO-ITEM-NODE*" "MAKE-INFO-ITEM-NODE"
+ "NMTOKEN-ATTR-NODE" "IS-NMTOKEN-ATTR-NODE" "*CLASS.NMTOKEN-ATTR-NODE*" "MAKE-NMTOKEN-ATTR-NODE"
+ "NMTOKENS-ATTR-NODE" "IS-NMTOKENS-ATTR-NODE" "*CLASS.NMTOKENS-ATTR-NODE*" "MAKE-NMTOKENS-ATTR-NODE"
+ "NOTATION-ATTR-NODE" "IS-NOTATION-ATTR-NODE" "*CLASS.NOTATION-ATTR-NODE*" "MAKE-NOTATION-ATTR-NODE"
+ "NOTATION-VALUE" "IS-NOTATION-VALUE" "*CLASS.NOTATION-VALUE*" "MAKE-NOTATION-VALUE"
+ "NS-NODE" "IS-NS-NODE" "*CLASS.NS-NODE*" "MAKE-NS-NODE"
+ "NUMBER-VALUE" "IS-NUMBER-VALUE" "*CLASS.NUMBER-VALUE*" "MAKE-NUMBER-VALUE"
+ "ORDINAL-NODE" "IS-ORDINAL-NODE" "*CLASS.ORDINAL-NODE*" "MAKE-ORDINAL-NODE"
+ "PI-NODE" "IS-PI-NODE" "*CLASS.PI-NODE*" "MAKE-PI-NODE"
+ "QNAME-ATTR-NODE" "IS-QNAME-ATTR-NODE" "*CLASS.QNAME-ATTR-NODE*" "MAKE-QNAME-ATTR-NODE"
+ "QNAME-CONTEXT" "IS-QNAME-CONTEXT" "*CLASS.QNAME-CONTEXT*" "MAKE-QNAME-CONTEXT"
+ "QNAME-VALUE" "IS-QNAME-VALUE" "*CLASS.QNAME-VALUE*" "MAKE-QNAME-VALUE"
+ "RECUR-DUR-ATTR-NODE" "IS-RECUR-DUR-ATTR-NODE" "*CLASS.RECUR-DUR-ATTR-NODE*" "MAKE-RECUR-DUR-ATTR-NODE"
+ "RECUR-DUR-VALUE" "IS-RECUR-DUR-VALUE" "*CLASS.RECUR-DUR-VALUE*" "MAKE-RECUR-DUR-VALUE"
+ "REF-CHARACTER-ENTITY" "IS-REF-CHARACTER-ENTITY" "*CLASS.REF-CHARACTER-ENTITY*" "MAKE-REF-CHARACTER-ENTITY"
+ "REF-ENTITY" "IS-REF-ENTITY" "*CLASS.REF-ENTITY*" "MAKE-REF-ENTITY"
+ "REF-GENERAL-ENTITY" "IS-REF-GENERAL-ENTITY" "*CLASS.REF-GENERAL-ENTITY*" "MAKE-REF-GENERAL-ENTITY"
+ "REF-NODE" "IS-REF-NODE" "*CLASS.REF-NODE*" "MAKE-REF-NODE"
+ "REF-PARAMETER-ENTITY" "IS-REF-PARAMETER-ENTITY" "*CLASS.REF-PARAMETER-ENTITY*" "MAKE-REF-PARAMETER-ENTITY"
+ "STRING-ATTR-NODE" "IS-STRING-ATTR-NODE" "*CLASS.STRING-ATTR-NODE*" "MAKE-STRING-ATTR-NODE"
+ "STRING-VALUE" "IS-STRING-VALUE" "*CLASS.STRING-VALUE*" "MAKE-STRING-VALUE"
+ "TIME-ATTR-NODE" "IS-TIME-ATTR-NODE" "*CLASS.TIME-ATTR-NODE*" "MAKE-TIME-ATTR-NODE"
+ "TIME-DUR-VALUE" "IS-TIME-DUR-VALUE" "*CLASS.TIME-DUR-VALUE*" "MAKE-TIME-DUR-VALUE"
+ "URI-REF-ATTR-NODE" "IS-URI-REF-ATTR-NODE" "*CLASS.URI-REF-ATTR-NODE*" "MAKE-URI-REF-ATTR-NODE"
+ "URI-REF-VALUE" "IS-URI-REF-VALUE" "*CLASS.URI-REF-VALUE*" "MAKE-URI-REF-VALUE"
+ "VALUE-NODE" "IS-VALUE-NODE" "*CLASS.VALUE-NODE*" "MAKE-VALUE-NODE"
+ ;; accessors
+ "URI"
+ "CHILDREN"
+ "ROOT"
+ "VALIDATE?"
+ "PARENT"
+ "DEF"
+ "DOCUMENT"
+ "EXPAND"
+ "NAMESPACES"
+ "ATTRIBUTES"
+ "PROPERTIES"
+ "NOTATION"
+ "ORDINALITY"
+ "MODEL"
+ "NODE-CLASS"
+ "NODE-VALIDATOR"
+ "VALUE"
+ "ENCODING"
+ "NODES"
+ "PREFIX"
+ "TARGET"
+ "DEREF"
+ "IS-FIXED"
+ "IS-REQUIRED"
+ "IS-IMPLIED"
+ "IS-EPHEMERAL"
+ "PROTOTYPE"
+ "STIPULATION"
+ "PROPS-DEFAULTED"
+ "PROPS-REQUIRED"
+
+ "VERSION"
+ "STANDALONE"
+ "SYSTEM-ID"
+ "PUBLIC-ID"
+ "NAMESPACE-NAME"
+ "LOCAL-NAME"
+
+ ;; additional accessors and abstract nodes which are not in the model
+ "ENTITIES"
+ "NOTATIONS"
+ "TYPES"
+ "ATTRIBUTES"
+ "PRECEDING-SIBLINGS"
+ "FOLLOWING-SIBLINGS"
+ "GENERAL-ENTITIES"
+ "PARAMETER-ENTITIES"
+ "NAMED-VALUE-NODE"
+ "ELEM-PROPERTY-NODE"
+ "ELEM-CHILD-NODE"
+ "DOC-CHILD-NODE"
+ "FUNCTION-VALUE"
+ "IS-FUNCTION-VALUE"
+ "EXPRESSION"
+ "CHARACTER-DATA-NODE"
+ "PI-NODES"
+ "COMMENT-NODES"
+ "CONTENT"
+ "ENTITY-INFO"
+ "REF-ELEM-NODE"
+ "REF-ELEM-PROPERTY-NODE"
+
+ "CLONE-NODE"
+ "LOCAL-PART"
+ "CHECK-CONSTRAINT"
+ "BIND-DEFINITION"
+ "COLLECT-MODEL-NAMES"
+ "FIRST-MODEL-NAME"
+ "ASSIGN-UNIVERSAL-NAMES"
+ "VALIDATE-CONTENT"
+
+ ;; serialization interface
+ "WRITE-NODE"
+ "*NODE-LEVEL*"
+ "*VERBOSE-QNAMES*"
+
+ "ELEMENT-APPEND"
+ "ELEMENT-GET"
+ "ELEMENT-SET"
+ "EXPORT-NAMES"
+ "FIND-ATTRIBUTE"
+ "FIND-ELEMENT"
+ "FIND-ELEMENT-BY-ID"
+ "FIND-NAME"
+ "FIND-NAMESPACE"
+ "FIND-PREFIX"
+ "INTERN-NAME"
+ "INTERN-PREFIX"
+ "INTERN-TYPE"
+ "MAKE-NAME"
+ "MAKE-QNAME"
+ "NAME"
+ "NAMESPACE"
+ "CONTENT-NAME-TYPE-NAME"
+
+ "*CONSTANT-PREFIX-STRINGS*"
+ "*DEF-NULL-NAMESPACE-NODE*"
+ "*DEFAULT-NAMESPACE-ATTRIBUTE-NAME*"
+ "*DEFAULT-PREFIX-NAME*"
+ "*DEFAULT-NAMESPACES*"
+ "*DEFAULT-NAMESPACE*"
+ "*DOCUMENT*"
+ "*ELEMENT-COUNT*"
+ "*EMPTY-NAME*"
+ "*GENERATED-NS-BINDINGS*"
+ "*INPUT-SOURCE*"
+ "*MIXED-NAME*"
+ "*NAMESPACE-BINDINGS*"
+ "*NAMESPACE-DICTIONARY*"
+ "*NAMESPACE-MODE*"
+ "*NAMESPACE*"
+ "*NULL-NAME*"
+ "*NULL-NAMESPACE*"
+ "*NULL-NAMESPACE-NODE*"
+ "*OUTPUT-DESTINATION*"
+ "*UNBINDABLE-PREFIX-STRINGS*"
+ "*XHTML-NAMESPACE*"
+ "*XMLNS-NAMESPACE*"
+ "*XML-NAMESPACE*"
+ "*XML-PREFIX-NAMESTRING*"
+ "*XMLNS-PREFIX-NAMESTRING*"
+ "*WILD-NAMESPACE*"
+ "*WILD-NAMESTRING*"
+ "*WILD-PREFIX*"
+ "*XML-NAMESPACE-ATTRIBUTE-NAME*"
+ "*XML-NAMESPACE-NODE*"
+ "*XMLNS-NAMESPACE-ATTRIBUTE-NAME*"
+ "*XMLNS-NAMESPACE-NODE*"
+ "*XSD-NAMESPACE*"
+ "PREFIX-VALUE"
+ "NAMESPACE-PREFIX"
+
+ ;; qualified name resolution
+ "*QNAME-EXTENT*"
+ "*DEF-TYPE-ID-QNAME-CONTEXTS*"
+ "*DEF-TYPE-MODEL-QNAME-CONTEXTS*"
+ "*DEF-ATTR-QNAME-CONTEXTS*"
+ "NEW-QNAME-EXTENT"
+ "QNAME-EXTENT"
+ "QNAME-EXTENT-EQUAL"
+ "*DISTINGUISH-QNAME-HOMOGRAPHS*"
+ "*CONFLATE-QNAME-SYNONYMS*"
+ "ACCUMULATE-QNAMES"
+ "ABSTRACT-NAME"
+ "UNAME"
+ "QNAME"
+
+ "VALUE-STRING"
+ "VALUE-NUMBER"
+ "VALUE-BOOLEAN"
+ "FIND-DEF-PARAMETER-ENTITY"
+ "FIND-DEF-GENERAL-ENTITY"
+ "FIND-DEF-ELEM-TYPE"
+ "FIND-DEF-NOTATION"
+
+ "IS-NAMECHARDATA"
+ "IS-NCNAME"
+
+ ;; utility functions
+ *SPECIALIZE-ELEM-NODE*
+ *SPECIALIZE-ATTR-NODE*
+ "*TOKEN-PACKAGE*"
+ "*WILD-NAME*"
+ "*WILD-UNAME*"
+ "*LANG-NAME*"
+ "!-reader"
+ "WALK-NODE"
+ "XML-ERROR"
+ "XML-EOF-ERROR"
+ "DOCUMENT-MODEL-ERROR"
+ "INTERNAL-XML-ERROR"
+ "VALIDITY-CERROR"
+ "VALIDITY-CONDITION"
+ "NAMESPACE-ERROR"
+ "WELLFORMEDNESS-ERROR"
+ "WELLFORMEDNESS-CERROR"
+ "SIMPLE-XML-ERROR"
+ "INCOMPLETE-PARSE"
+ "PRINT-QNAME"
+ "PRINT-NS-NODE"
+
+ "COLLECT-NODE-BY-TYPE"
+ "MAP-NODE-BY-TYPE"
+
+ "COLLECT-ATTRIBUTE-DECLARATIONS"
+ "COLLECT-ATTRIBUTES"
+ "COLLECT-COMMENTS"
+ "COLLECT-COMMENTS-AND-PIS"
+ "COLLECT-DECLARATIONS"
+ "COLLECT-ELEMENT-DECLARATIONS"
+ "COLLECT-ELEMENT-PROPERTIES"
+ "COLLECT-ELEMENTS"
+ "COLLECT-GENERAL-ENTITIES"
+ "COLLECT-NAMESPACES"
+ "COLLECT-NOTATIONS"
+ "COLLECT-PARAMETER-ENTITIES"
+ "COLLECT-PIS"
+
+ "UNAME-EQUAL"
+ "QNAME-EQUAL"
+ "NODE-EQUAL"
+ "MAKE-DOCUMENT-NAMESPACE-BINDINGS"
+ "content-model"
+ "|-content"
+ "?-content"
+ "*-content"
+ "bounded-content"
+ "MIXED-content"
+ "+-content"
+ "content"
+ ",-content"
+ "content-name"
+ "type-name"
+ "mixed-atn"
+ "element-atn"
+
+ ;; character classes
+ "XML-CHAR?"
+ "XML-SPACE?"
+ "XML-IDEOGRAPHIC?"
+ "XML-BASECHAR?"
+ "XML-LETTER?"
+ "XML-DIGIT?"
+ "XML-COMBININGCHAR?"
+ "XML-EXTENDER?"
+ "XML-NAMECHAR?"
+ "XML-INITIAL-NAMECHAR?"
+ "XML-PUBIDCHAR?"
+ "XML-MARKUPCHAR?"
+ "XML-LATINALPHACHAR?"
+ "XML-LATINCHAR?"
+ "XML-LANGUAGEIDCHAR?"
+ "XML-VERSIONNUMCHAR?"
+ "XML-MODEL-OP-CHAR?"
+ "XML-SUCCESSOR-EOLCHAR?"
+ "XML-INITIAL-EOLCHAR?"
+
+ ;; graphs
+ "WRITE-NODE-GRAPH"
+ "ENCODE-NODE-GRAPH"
+ "NODE-GRAPH-PROPERTIES"
+ "NODE-LINK-PROPERTIES"
+
+ ;; 0.950 compatibility
+ :annotation-model
+ :constant-prefix-p
+ :direct-annotation-model
+ :condition-name
+ :condition-namespace
+ :document
+ :document-element
+ :element-definition
+ :element-p
+ :general-entity-definition
+ :id-attr-node-p
+ :namespace-declaration
+ :namespace-equal
+ :parameter-entity-definition
+ :type-definition
+ :unbindable-prefix-p
+ :with-namespaces
+ :default-namespace
+ :*default-prefix-string*
+ :local-part-equal
+ :valid
+ :namespace-printname
+
+ ".//*"
+ ".//"
+ "./@"
+ "./@-STRING"
+ "./@-VALUE"
+ "./"
+ "./-STRING"
+ "./-VALUE"
+
+ ))
+
+(defPackage "XML-PARSER"
+ (:nicknames "XMLP"
+ :de.setf.xml
+ :de.setf.xml.interface
+ :de.setf.xml.codec.implementation
+ :de.setf.xml.process.implementation)
+ (:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XQDM" "XUTILS")
+ #+CCL (:shadowing-import-from "XQDM" "TARGET")
+ (:export
+ "*CONSTRUCTION-CONTEXT*"
+ "*SPECIALIZE-ELEM-NODE*"
+ "*SPECIALIZE-ATTR-NODE*"
+ "AttCharData-Constructor"
+ "Attribute-Constructor"
+ "CALL-WITH-NAME-PROPERTIES"
+ "CharData-Constructor"
+ "CDataCharData-Constructor"
+ "Comment-Constructor"
+ "CONSTRUCT-ATTRIBUTE-NAME"
+ "CONSTRUCT-ATTRIBUTE-PLIST"
+ "CONSTRUCT-CONSTRUCTION-CONTEXT"
+ "CONSTRUCT-CONTENT-SEQUENCE"
+ "CONSTRUCT-ELEM-PROPERTY-NODE"
+ "CONSTRUCT-ELEMENT-NAME"
+ "CONSTRUCT-ELEMENT-NODE"
+ "CONSTRUCT-NS-NODE"
+ "CONSTRUCT-STRING-ATTR-NODE"
+ "Content-Constructor"
+ "ContentSequence-Constructor"
+ ;; the constructor method for attribute default values remains unexported
+ ;; until specialization is implemented for the DTD as a whole...
+ ;; "DefaultAttCharData-Constructor"
+ "DEFPIFUNCTION"
+ "Document-Constructor"
+ "DOCUMENT-PARSER"
+ "Element-Constructor"
+ "ENCODE-CHAR"
+ "ENCODE-FORMAT"
+ "ENCODE-NODE"
+ "ENCODE-STRING"
+ "ENCODE-NEWLINE"
+ "ExtParsedEnt-Constructor"
+ "Pi-Constructor"
+ "PI-FUNCTION"
+ "PiCharData-Constructor"
+ ;; "MAKE-NCNAME"
+ ;; "MAKE-UNAME"
+ "PARSE-EXTERNAL-ENTITY-DATA"
+ "PARSE-EXTERNAL-SOURCE"
+ "PARSE-EXTERNAL-SUBSET"
+ "PARSE-EXTERNAL-GENERAL-ENTITY"
+ "READ-EXTERNAL-ENTITY-DATA"
+ "STag-Constructor"
+ "WRITE-NODE"
+ "WRITER-STREAM"
+ "XML"
+ "*XML-WRITER-STREAM*"
+ "WITH-XML-WRITER"
+
+ ;; 0.950 compatibility
+ :prefix-namespace
+ )
+ )
+
+(defPackage "XML-PATH"
+ (:nicknames "XP")
+ (:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XQDM" "XUTILS")
+ ;; the term 'step' is central to the standard so it is shadowed rather
+ ;; than using an alternative.
+ (:shadow "STEP")
+ #+CCL (:shadowing-import-from "XQDM" "TARGET")
+ (:EXPORT
+ "PATH" "STEP" "CONTEXT"
+ "PATH-ELEMENT" "STEP-ELEMENT" "STEP-GENERATOR" "STEP-FILTER"
+ "ENUMERATING-STEP-GENERATOR" "LIST-GENERATOR" "AXIS-GENERATOR"
+ "MAP-NODES" "NAME-TEST" "NODE-SET" "NODE-TEST" "TYPE-TEST"
+ "TERM" "IS-ABSOLUTE" "STEPS" "GENERATOR"
+ "TEST" "PREDICATES" "SOURCE" "PREFIX" "LOCAL-PART"
+ "STEP-GENERATOR-FUNCTION" "STEP-PREDICATE-FUNCTION"
+ "LITERAL"
+ "NODE" "LOCATION" "SIZE" "BINDINGS" "VARIABLES" "FUNCTIONS" "NAMESPACES"
+ "EXPRESSION"
+
+ "*CLASS.PATH*"
+ "*CLASS.STEP*"
+ "*CLASS.CONTEXT*"
+ "*CLASS.CHILD*"
+ "*DOCUMENTS*"
+ )
+ )
+
+(defPackage "XML-QUERY"
+ (:nicknames "XQ")
+ (:use "BNFP" #+CCL "CCL" "COMMON-LISP" "XQDM" "XUTILS")
+ #+CCL (:shadowing-import-from "XQDM" "TARGET")
+ )
+
+
+(defPackage "xml" (:use)
+ (:nicknames "http://www.w3.org/XML/1998/namespace")
+ (:export " " "!=" "!=" "!==" "\"" "#FIXED" "#IMPLIED" "#PCDATA" "#REQUIRED"
+ "$" "%" "&" "&#" "&#x" "'" "(" "()" ")" ")*" "*" "*:" "+" ","
+ "-" "-->" "->" "." ".." "/" "//" "/>" ":" ":=" "::" ":*" ";" "<" "<!" "<!--"
+ "<!ATTLIST" "<!DOCTYPE" "<!ELEMENT" "<!ENTITY" "<!NOTATION"
+ "<![" "<![CDATA[" "</" "<=" "<?" "<?xml" "=" "==" ">" ">=" "?" "?>"
+ "@" "AFTER" "ANY" "ASCENDING" "BEFORE" "CDATA" "DESCENDING" "EMPTY"
+ "ENTITIES" "ENTITY" "ID" "IDREF" "IDREFS" "IGNORE" "INCLUDE"
+ "NDATA" "NMTOKEN" "NMTOKENS" "NOT" "NOTATION" "PUBLIC" "SYSTEM"
+ "[" "]" "]]>" "^"
+ "ancestor" "ancestor-or-self" "and" "attribute"
+ "child" "comment"
+ "descendant" "descendant-or-self" "div" "document"
+ "encoding" "following" "following-sibling"
+ "id" "key" "lang"
+ "mixed" "mod" "namespace" "no" "node" "not" "or"
+ "parent" "preceding" "preceding-sibling" "processing-instruction"
+ "root" "self" "standalone" "text" "union" "version" "xml" "yes"
+ "{" "|" "}" "�"))
+;;
+;;
+;; packages for implementing xml data modeling.
+;; types from the datatype package appear in expression in the two algrbras. they are
+;; exported, but not used/imported, as the customary expression uses the prefix.
+;; the case distinctions distinguish grammatic meta-symbols which participate in special
+;; forms from the names for functions and types, which conserve case.
+
+;; package for xml query types
+(defPackage "XML-SCHEMA-DATATYPES" (:use) (:nicknames "XSD")
+ (:export "TYPEP" "TYPEP-SPECIALIZED"
+ "IS-anyComplexType" "IS-anySimpleType" "IS-anyTreeType" "IS-anyType" "IS-anyURI"
+ "IS-attribute" "IS-base64Binary" "IS-boolean" "IS-byte" "IS-comment" "IS-complex"
+ "IS-date" "IS-dateTime"
+ "IS-decimal" "IS-double" "IS-duration"
+ "IS-element" "IS-ENTITY" "IS-ENTITIES" "IS-float"
+ "IS-gDay" "IS-gMonth" "IS-gMonthDay" "IS-gYear"
+ "IS-hexBinary" "IS-ID" "IS-IDREF" "IS-IDREFS"
+ "IS-int" "IS-integer" "IS-language" "IS-long"
+ "IS-Name" "IS-NCName" "IS-NMTOKEN" "IS-NMTOKENS"
+ "IS-negativeInteger" "IS-nonNegativeInteger" "IS-nonPositiveInteger" "IS-normalizedString"
+ "IS-NOTATION" "IS-pi" "IS-positiveInteger" "IS-scalar" "IS-short" "IS-simple"
+ "IS-string" "IS-time" "IS-token" "IS-UName"
+ "IS-unsignedByte" "IS-unsignedInt" "IS-unsignedLong" "IS-unsignedShort"
+
+ "VALIDATE-STRING" "VALIDATE-ATTRIBUTE" "VALIDATE-NAME"))
+
+;; package for xml path "algebra" operators
+(defPackage "XML-PATH-ALGEBRA" (:use) (:nicknames "XPA")
+ (:import-from "xml" "document")
+ (:intern "APPLY-DESCENDANTS-PATH" "APPLY-CHILD-PATH" "APPLY-PATH"
+ "APPLY-PREDICATE-PATH" "APPLY-STEP"
+ "EVAL" "FUNCALL" "LANGUAGE-EQUAL" "NODES" "VARIABLE"
+ "SYMBOL-FUNCTION" "GENSYM")
+ (:export
+ ;; path components
+ "PATH" "STEP" "UNAME"
+ "ID-STEP" "KEY-STEP" "PARENT-STEP" "ROOT-STEP" "SELF-STEP" "WILD-INFERIOR-STEP"
+ "AXIS-GENERATOR" "LIST-GENERATOR"
+ "ANCESTOR" "ANCESTOR-OR-SELF" "ATTRIBUTE" "CHILD" "DESCENDANT"
+ "DESCENDANT-OR-SELF" "FOLLOWING" "FOLLOWING-OR-SELF" "FOLLOWING-SIBLING"
+ "ID" "KEY"
+ "NAMESPACE" "PARENT" "PRECEDING" "PRECEDING-SIBLING" "ROOT" "SELF"
+ "NAME-TEST" "@NAME-TEST" "TYPE-TEST" "TYPE-NAME-TEST"
+ "PI-TEST" "COMMENT-TEST" "TEXT-TEST"
+ "PREDICATE"
+ ;; state variables
+ "*CONTEXT-NODE*" "*POSITION*" "*COUNT*"
+ ;; library functions
+ "and"
+ "boolean"
+ "ceiling" "contains" "count"
+ "document"
+ "false" "floor"
+ "id"
+ "last" "local-name" "lang"
+ "mod"
+ "name" "namespace-uri" "normalize-space" "not" "number"
+ "or"
+ "position"
+ "round"
+ "starts-with" "string" "substring"
+ "substring-after" "substring-before"
+ "string-length" "sum"
+ "translate" "true"
+ "union"
+ "+" "-" "*" "/" "<" "<=" ">" ">=" "=" "!="
+ "NaN" "0+" "0-" "infinity+" "infinity-"
+ ))
+
+;; package for xml query algebra operators
+(defPackage "XML-QUERY-ALGEBRA" (:use) (:nicknames "XQA")
+ (:import-from "XPA"
+ "and"
+ "boolean"
+ "ceiling" "contains" "count"
+ "document"
+ "false" "floor"
+ "id"
+ "last" "local-name" "lang"
+ "mod"
+ "name" "namespace-uri" "normalize-space" "not" "number"
+ "or"
+ "position"
+ "round"
+ "starts-with" "string" "substring"
+ "substring-after" "substring-before"
+ "string-length" "sum"
+ "translate" "true"
+ "union"
+ ;; these are not imported "<" "<=" ">" ">=" "="
+ ;; as the comparison differs
+ "+" "-" "*" "/" "!="
+ "NaN" "0+" "0-" "infinity+" "infinity-"
+ "GENSYM")
+ (:EXPORT "IF" "LET" "ELSE" "FOR" "MATCH" "CASE" "WHERE"
+ "TYPE" "FUN" "QUERY"
+ "AND" "OR" "NOT" "DIV" "MOD" "SCHEMA"
+ "+" "-" "*" "<" "<=" ">" ">=" "=" "==" "!=" "!=="
+ "//" "/" "." "|"
+ "DEFUN"
+ "ATTRIBUTE" "ELEMENT"
+ "MAKE-NCNAME" "MAKE-TNAME" "MAKE-UNAME"
+ "sequence" "UNION" "DIFFERENCE" "INTERSECTION" "SORT"
+ "ERROR" "INSTANCEOF" "BEFORE" "AFTER"
+ "TYPEP" "TYPE" "SORT"
+ "TYPE-REF" "ID-TEST" "TYPEP" "RANGE-TEST"
+ ;; xpath algebra symbols
+ "and"
+ "boolean"
+ "cdata" "ceiling" "contains" "count"
+ "document"
+ "false" "floor"
+ "id"
+ "last" "local-name" "lang"
+ "mod"
+ "name" "namespace-uri" "normalize-space" "not" "number"
+ "or"
+ "position"
+ "round"
+ "starts-with" "string" "substring"
+ "substring-after" "substring-before"
+ "string-length" "sum"
+ "translate" "true"
+ "union"
+ "NaN" "0+" "0-" "infinity+" "infinity-"
+ ;; xml query algebra specific
+ "avg"
+ "bagtolist"
+ "data" "difference" "distinct_nodes" "distinct_value"
+ "comment" "Comment" "deref"
+ "except"
+ "index" "intersection"
+ "listtobag" "localname"
+ "max" "min"
+ "namespace" "nodes"
+ "parent" "processing_instruction"
+ "ref"
+ "sequence" "sort"
+ "target"
+ "value"
+
+
+ "empty"
+ "==" ))
+
+(defPackage "$" (:use))
+
+(defpackage "XML-QUERY-LANGUAGE" (:use) (:nicknames "XQL")
+ (:import-from "XPA"
+ "and"
+ "boolean"
+ "ceiling" "contains" "count"
+ "document"
+ "false" "floor"
+ "id"
+ "last" "local-name" "lang"
+ "mod"
+ "name" "namespace-uri" "normalize-space" "not" "number"
+ "or"
+ "position"
+ "round"
+ "starts-with" "string" "substring"
+ "substring-after" "substring-before"
+ "string-length" "sum"
+ "translate" "true"
+ "union"
+ "+" "-" "*" "/" "!="
+ "NaN" "0+" "0-" "infinity+" "infinity-")
+ (:import-from "XQA"
+ "<" "<=" ">" ">=" "=")
+ (:export "ELEMENT" "ATTRIBUTE" "CAST" "TREAT" "INTERSECT" "EXCEPT"
+ "INSTANCEOF" "SOME" "EVERY" "FUNCTION"
+ "FUNCALL" "NAMESPACE-DECL" "QNAME" "SCHEMA-DECL"
+ "ID-PATH" "ATTRIBUTE-PATH" "TYPE-PATH" "ELEMENT-PATH"
+ "RANGE" "/" "//" "*" "STEP" "TYPE"
+ ;; xpath algebra symbols
+ "and"
+ "boolean"
+ "ceiling" "contains" "count"
+ "document"
+ "false" "floor"
+ "id"
+ "last" "local-name" "lang"
+ "mod"
+ "name" "namespace-uri" "normalize-space" "not" "number"
+ "or"
+ "position"
+ "round"
+ "starts-with" "string" "substring"
+ "substring-after" "substring-before"
+ "string-length" "sum"
+ "translate" "true"
+ "union"
+ "+" "-" "*" "/" "<" "<=" ">" ">=" "=" "!="
+ "NaN" "0+" "0-" "infinity+" "infinity-"
+ ;; xquery language library
+ "comment" "date" "distinct"
+ "empty" "equal" "filter" "last"
+ "name" "number" "pi" "union"))
+
+
+;; additions for cl-http tokenizer
+#-CL-HTTP
+(defpackage "WWW-UTILS"
+ (:use common-lisp)
+ (:intern "WITH-FAST-ARRAY-REFERENCES" "MAKE-LOCK" "WITH-LOCK-HELD"))
+
+#-CL-HTTP
+(defpackage tk1
+ (:use common-lisp)
+ (:import-from "WWW-UTILS" "WITH-FAST-ARRAY-REFERENCES" "MAKE-LOCK" "WITH-LOCK-HELD")
+ (:export
+ "*DEFAULT-TOKENIZER-SIZE*"
+ "CLEAR-TOKENIZER"
+ "CREATE-TOKENIZER"
+ "DEFINE-TOKENIZER"
+ "DESCRIBE-TOKENIZER"
+ "FIND-TOKENIZER-NAMED"
+ "GET-TOKEN"
+ "INSERT-TOKEN"
+ "MAP-TOKENS"
+ "REHASH-TOKENIZER"
+ "REMOVE-TOKEN"
+ "TOKENIZE"
+ "UNDEFINE-TOKENIZER"))
+
+#-CL-HTTP
+(defPackage "HTTP"
+ (:export "*STANDARD-CHARACTER-TYPE*"))
+
+:EOF
+
+
1
0
14 Feb '06
Author: banderson
Date: Tue Feb 14 11:53:49 2006
New Revision: 9
Added:
branches/sbcl-0.9.x-testing/bin/sbclfasl/
branches/sbcl-0.9.x-testing/bin/sbclfasl/README.txt
Log:
adding bin folder for sbcl fasl files
Added: branches/sbcl-0.9.x-testing/bin/sbclfasl/README.txt
==============================================================================
--- (empty file)
+++ branches/sbcl-0.9.x-testing/bin/sbclfasl/README.txt Tue Feb 14 11:53:49 2006
@@ -0,0 +1 @@
+this directory is intended to contain generated files.
1
0
[cl-xml-cvs] r8 - in branches/sbcl-0.9.x-testing/code: atn-parser xparser xquerydatamodel
by banderson＠common-lisp.net 14 Feb '06
by banderson＠common-lisp.net 14 Feb '06
14 Feb '06
Author: banderson
Date: Tue Feb 14 11:52:41 2006
New Revision: 8
Modified:
branches/sbcl-0.9.x-testing/code/atn-parser/ebnf-tokenizer.lisp
branches/sbcl-0.9.x-testing/code/xparser/xml-printer.lisp
branches/sbcl-0.9.x-testing/code/xparser/xml-stream-coding.lisp
branches/sbcl-0.9.x-testing/code/xquerydatamodel/xqdm-classes.lisp
Log:
some re-arranging from old releases
Modified: branches/sbcl-0.9.x-testing/code/atn-parser/ebnf-tokenizer.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/atn-parser/ebnf-tokenizer.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/atn-parser/ebnf-tokenizer.lisp Tue Feb 14 11:52:41 2006
@@ -1 +1,553 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: bnf-parser; -*-
#|
<DOCUMENTATION>
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
href='file://bnfp/sysdcl.lisp' />
<CHRONOLOGY>
<DELTA DATE='19980331' AUTHOR='BB'>added ',' and '->' to grammar</DELTA>
<DELTA DATE='20010605' AUTHOR='MS'>explicit quoted string reader</DELTA>
<DELTA DATE='20010605' AUTHOR='JAA'>productions id for [[#]]</DELTA>
<DELTA DATE='20010618'>fixed incorrect readers for square brackets</DELTA>
<DELTA DATE='20010719' AUTHOR='JCMA'>readtable mods as function</DELTA>
<DELTA DATE='20010931'>fixed premature termination bug in comment-reader</DELTA>
<DELTA DATE='20030529'>corrected eof errors in [,] readers</DELTA>
<DELTA DATE='20030601'>modified // comment reader to recognize both (CR LF) newline forms</DELTA>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "BNF-PARSER")
(defparameter *bnf-readtable* (copy-readtable nil))
(defparameter *ansi-cl-readtable* (copy-readtable nil))
(defparameter *metasymbols*
'(|\|| * ? + - |)| |(| |'| |::=| |#[| |^| |[| |[[| |]| |]]| |/*| |/**| |//| |*/| \; \, |->| |{| |}| |'(|
)
"nb. all metasymbols must appear here. any other text is coerced to a string.
they must also be correctly categorized in ebnf-grammar.atn. anything else
will aslo be treated as a symbol.")
(defun defsymbol-reader (stream char)
(declare (ignore char))
(set-macro-character #\: #'(lambda (s c) (declare (ignore s c)))
nil
*bnf-readtable*)
(read-char stream)
(read-char stream)
(set-macro-character #\: #'defsymbol-reader nil *bnf-readtable*)
'|::=| )
(defun \'reader (stream term-char)
(coerce (loop for char = (read-char stream)
until (eql char term-char)
collect (if (eql char #\\) (read-char stream) char))
'string))
(defun [reader (stream char)
(declare (ignore char))
(cond ((char= #\[ (peek-char nil stream nil nil))
(read-char stream)
'[[)
(t '[)))
(defun ]reader (stream char)
(declare (ignore char))
(cond ((char= #\] (peek-char nil stream nil nil))
(read-char stream)
']])
(t '])))
(defun \#reader (stream char)
(set-macro-character #\[ #'(lambda (s c) (declare (ignore s c)) #\[)
nil
*bnf-readtable*)
(prog1
(cond ((eql (peek-char nil stream nil nil) #\[)
(read-char stream)
'|#[|)
((eql (peek-char nil stream nil nil) #\')
#\#)
(t (read-number-string stream char)))
(set-macro-character #\[ #'[reader nil *bnf-readtable*)))
(defun /reader (stream char)
(cond ((char= (peek-char nil stream nil nil) #\/)
(read-char stream)
(let ((char nil))
(loop (unless (setf char (read-char stream nil nil)) (return))
(when (member char '(#\return #\linefeed)) (return)))
:comment))
((char= (peek-char nil stream nil nil) #\*)
(read-comment-string stream)
:comment)
(t char)))
(defun read-comment-string (stream &aux (output (make-string-output-stream)))
(write-char #\/ output)
(write-char (read-char stream) output)
(loop with dispatch-char
for char = (read-char stream nil nil)
while char
do (cond ((and dispatch-char (char= #\/ char))
(write-char char output)
(return-from read-comment-string (get-output-stream-string output)))
((char= char #\*) (setf dispatch-char t))
(t (setf dispatch-char nil)))
(write-char char output)))
(defun read-number-string (stream char &aux (output (make-string-output-stream)))
(let ((*readtable* (copy-readtable nil)))
(set-syntax-from-char #\- #\a *readtable*)
(set-syntax-from-char #\# #\a *readtable*)
(write-char char output)
(do ((i 0 (1+ i))
(nc (peek-char nil stream nil nil)
(peek-char nil stream nil nil)))
((or (null nc) (member nc '(#\] #\- #\space)))
(get-output-stream-string output))
(write-char (read-char stream) output))))
(defun -reader (stream char)
(declare (ignore char))
(let ((next (peek-char nil stream nil nil)))
(if (eql next #\>)
(progn (read-char stream) '|->|)
'-)))
(defun initialize-bnf-readtable (readtable)
(flet ((char-name-reader (name)
#'(lambda (stream char)
(declare (ignore stream char))
name)))
(if (fboundp 'readtable-case) (setf (readtable-case readtable) :preserve))
(set-macro-character #\| (char-name-reader '\|) nil readtable)
(set-macro-character #\* (char-name-reader '*) nil readtable)
(set-macro-character #\? (char-name-reader '?) nil readtable)
(set-macro-character #\+ (char-name-reader '+) nil readtable)
(set-macro-character #\( (char-name-reader '\() nil readtable)
(set-macro-character #\) (char-name-reader '\)) nil readtable)
(set-macro-character #\- #'-reader nil readtable)
(set-macro-character #\^ (char-name-reader '\^) nil readtable)
(set-macro-character #\[ '[reader nil readtable)
(set-macro-character #\] ']reader nil readtable)
(set-macro-character #\{ (char-name-reader '\{) nil readtable)
(set-macro-character #\} (char-name-reader '\}) nil readtable)
(set-macro-character #\# #'\#reader nil readtable)
(set-macro-character #\, (char-name-reader '\,) nil readtable)
(set-macro-character #\: #'defsymbol-reader nil readtable)
(set-macro-character #\; (char-name-reader '\;) nil readtable)
;; (set-syntax-from-char #\/ #\" readtable)
(set-macro-character #\/ #'/reader nil readtable)
(set-syntax-from-char #\" #\a readtable)
;; 20010301.jaa reinstated
(set-syntax-from-char #\# #\a readtable)
;; 20010605.ms (set-syntax-from-char #\' #\" readtable)
(set-macro-character #\' '\'reader nil readtable)
;; 20010122.jaa
(set-macro-character #\. (char-name-reader '\.) nil readtable)
))
(initialize-bnf-readtable *bnf-readtable*)
(defun bnf-reader (bnf-str &aux (*readtable* *bnf-readtable*)
#+:aclpc (allegro::*read-case* :leave))
(loop with bnf-length = (length bnf-str)
with open-range
with tokens
with start = 0
if (< start bnf-length)
do
(multiple-value-bind (expr end)
(read-from-string bnf-str nil nil :start start)
;; (print expr)
(cond ((null expr)
(return-from bnf-reader (nreverse tokens)))
((eq expr :comment)
(setf start end))
(t
(cond ((member expr *metasymbols*)
(cond ((eq expr '\[) (setf open-range t))
((eq expr '\]) (setf open-range nil)))
(push expr tokens))
((stringp expr) ;; terminale
(cond ((and (> (length expr) 0) (char= (char expr 0) #\#) ;; leave non-hex as string
(not (find-if #'(lambda (c) (not (digit-char-p c 16))) expr)))
(cond (open-range
;; Range ohne terminale delimiter
(push expr tokens))
(t (push '\' tokens)
;; the originl pushed a number ?
;; (push (hex-string-to-number expr) tokens)
(push (make-string 1 :initial-element (code-char (hex-string-to-number expr))) tokens)
(push '\' tokens))))
(t (push '\' tokens)
(push expr tokens)
(push '\' tokens))))
((numberp expr)
(push (format nil "~A" expr) tokens))
(t (push (string expr) tokens)))
(setf start end))))
else return (nreverse tokens)))
(defun hex-string-to-number (expr)
(let ((*readtable* *ansi-cl-readtable*))
(read-from-string expr)))
(defun alternative-chars (str)
(format nil "~{'~A'~^ | ~}" (coerce str 'list)))
(defun sequence-chars (str)
(format nil "~{'~A'~^ ~}" (coerce str 'list)))
(defmethod hexstring ((object character))
(let ((*print-base* 16))
(format nil "#x~A" (char-code object))))
#|
(hexstring #\a)
(alternative-chars "adfa")
(sequence-chars "adf")
(bnf-reader "[a b c]")
(defun hex-string-to-char (expr)
(let ((*readtable* *ansi-cl-readtable*))
(code-char (read-from-string expr))))
(defun read-number-string (stream char &aux (output (make-string-output-stream)))
(write-char char output)
(let ((*readtable* (copy-readtable nil)))
(set-syntax-from-char #\- #\a *readtable*)
(loop
for nc = (peek-char nil stream nil nil)
for i from 0
while (and nc (char/= nc #\] #\- #\# #\space))
do (write-char (read-char stream) output))
(get-output-stream-string output)))
;; Beispiele
(bnf-reader "// doc Dies
s ::= /* comment */ 'a'")
;; note the escaping form when evaluating tests strings ...
(bnf-reader "SingleQuote ::= '\\'' ")
(bnf-reader "DoubleQuote ::= '\"' ")
(bnf-to-atn
(bnf-object-tree
(caar (callparser 'ebnf
(bnf-reader "root ::= cell+ cell ::= [2,3 -> 'foo']")))))
(bnf-to-atn
(bnf-object-tree
(caar (callparser 'ebnf
(bnf-reader "s ::= #[print foo] [^#xd-#xh] | [^#x45#x45] | [#x45-#x65] #[print a]")))))
(write-source
(bnf-to-atn
"test ::= 'a' range '.' range ::= [a-z] | [^U-Z]")
"TestParser")
;;; #[print a]
;;; terminal-delimiter ::= '''
(bnf-object-tree
(callparser 'ebnf
(bnf-reader
"ebnf ::= definition+
definition ::= symbol defsymbol rhs
rhs ::= qexpr+ | alternative
qexpr ::= (symbol | group) occurrence?
group ::= leftpar (qexpr+ | alternative) rightpar
alternative ::= qexpr oneof (qexpr | alternative)
symbol ::= terminal | nonterminal
nonterminal ::= token
terminal ::= terminal-delimiter token terminal-delimiter
leftpar ::= '('
rightpar ::= ')'
oneof ::= '|'
defsymbol ::= '::='
occurrence ::= '+' | '*' | '?'") ) )
|#
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: bnf-parser; -*-
+
+
+
+#|
+
+<DOCUMENTATION>
+
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+
+ href='file://bnfp/sysdcl.lisp' />
+
+ <CHRONOLOGY>
+
+ <DELTA DATE='19980331' AUTHOR='BB'>added ',' and '->' to grammar</DELTA>
+
+ <DELTA DATE='20010605' AUTHOR='MS'>explicit quoted string reader</DELTA>
+
+ <DELTA DATE='20010605' AUTHOR='JAA'>productions id for [[#]]</DELTA>
+
+ <DELTA DATE='20010618'>fixed incorrect readers for square brackets</DELTA>
+
+ <DELTA DATE='20010719' AUTHOR='JCMA'>readtable mods as function</DELTA>
+
+ <DELTA DATE='20010931'>fixed premature termination bug in comment-reader</DELTA>
+
+ </CHRONOLOGY>
+
+ </DOCUMENTATION>
+
+|#
+
+
+
+(in-package "BNF-PARSER")
+
+
+
+(defparameter *bnf-readtable* (copy-readtable nil))
+
+(defparameter *ansi-cl-readtable* (copy-readtable nil))
+
+(defparameter *metasymbols*
+
+ '(|\|| * ? + - |)| |(| |'| |::=| |#[| |^| |[| |[[| |]| |]]| |/*| |/**| |//| |*/| \; \, |->| |{| |}| |'(|
+
+ )
+
+ "nb. all metasymbols must appear here. any other text is coerced to a string.
+
+ they must also be correctly categorized in ebnf-grammar.atn. anything else
+
+ will aslo be treated as a symbol.")
+
+
+
+(defun defsymbol-reader (stream char)
+
+ (declare (ignore char))
+
+ (set-macro-character #\: #'(lambda (s c) (declare (ignore s c)))
+
+ nil
+
+ *bnf-readtable*)
+
+ (read-char stream)
+
+ (read-char stream)
+
+ (set-macro-character #\: #'defsymbol-reader nil *bnf-readtable*)
+
+ '|::=| )
+
+
+
+(defun \'reader (stream term-char)
+
+ (coerce (loop for char = (read-char stream)
+
+ until (eql char term-char)
+
+ collect (if (eql char #\\) (read-char stream) char))
+
+ 'string))
+
+
+
+(defun [reader (stream char)
+
+ (declare (ignore char))
+
+ (cond ((char= #\[ (peek-char nil stream))
+
+ (read-char stream)
+
+ '[[)
+
+ (t '[)))
+
+
+
+(defun ]reader (stream char)
+
+ (declare (ignore char))
+
+ (cond ((char= #\] (peek-char nil stream))
+
+ (read-char stream)
+
+ ']])
+
+ (t '])))
+
+
+
+(defun \#reader (stream char)
+
+ (set-macro-character #\[ #'(lambda (s c) (declare (ignore s c)) #\[)
+
+ nil
+
+ *bnf-readtable*)
+
+ (prog1
+
+ (cond ((eql (peek-char nil stream nil nil) #\[)
+
+ (read-char stream)
+
+ '|#[|)
+
+ ((eql (peek-char nil stream nil nil) #\')
+
+ #\#)
+
+ (t (read-number-string stream char)))
+
+ (set-macro-character #\[ #'[reader nil *bnf-readtable*)))
+
+
+
+(defun /reader (stream char)
+
+ (cond ((char= (peek-char nil stream nil nil) #\/)
+
+ (read-char stream)
+
+ (let ((*readtable* *ansi-cl-readtable*))
+
+ (read-line stream)
+
+ :comment))
+
+ ((char= (peek-char nil stream nil nil) #\*)
+
+ (read-comment-string stream)
+
+ :comment)
+
+ (t char)))
+
+
+
+(defun read-comment-string (stream &aux (output (make-string-output-stream)))
+
+ (write-char #\/ output)
+
+ (write-char (read-char stream) output)
+
+ (loop with dispatch-char
+
+ for char = (read-char stream nil nil)
+
+ while char
+
+ do (cond ((and dispatch-char (char= #\/ char))
+
+ (write-char char output)
+
+ (return-from read-comment-string (get-output-stream-string output)))
+
+ ((char= char #\*) (setf dispatch-char t))
+
+ (t (setf dispatch-char nil)))
+
+ (write-char char output)))
+
+
+
+(defun read-number-string (stream char &aux (output (make-string-output-stream)))
+
+ (let ((*readtable* (copy-readtable nil)))
+
+ (set-syntax-from-char #\- #\a *readtable*)
+
+ (set-syntax-from-char #\# #\a *readtable*)
+
+ (write-char char output)
+
+ (do ((i 0 (1+ i))
+
+ (nc (peek-char nil stream nil nil)
+
+ (peek-char nil stream nil nil)))
+
+ ((or (null nc) (member nc '(#\] #\- #\space)))
+
+ (get-output-stream-string output))
+
+ (write-char (read-char stream) output))))
+
+
+
+(defun -reader (stream char)
+
+ (declare (ignore char))
+
+ (let ((next (peek-char nil stream nil nil)))
+
+ (if (eql next #\>)
+
+ (progn (read-char stream) '|->|)
+
+ '-)))
+
+
+
+(defun initialize-bnf-readtable (readtable)
+
+ (flet ((char-name-reader (name)
+
+ #'(lambda (stream char)
+
+ (declare (ignore stream char))
+
+ name)))
+
+ (if (fboundp 'readtable-case) (setf (readtable-case readtable) :preserve))
+
+ (set-macro-character #\| (char-name-reader '\|) nil readtable)
+
+ (set-macro-character #\* (char-name-reader '*) nil readtable)
+
+ (set-macro-character #\? (char-name-reader '?) nil readtable)
+
+ (set-macro-character #\+ (char-name-reader '+) nil readtable)
+
+ (set-macro-character #\( (char-name-reader '\() nil readtable)
+
+ (set-macro-character #\) (char-name-reader '\)) nil readtable)
+
+ (set-macro-character #\- #'-reader nil readtable)
+
+ (set-macro-character #\^ (char-name-reader '\^) nil readtable)
+
+ (set-macro-character #\[ '[reader nil readtable)
+
+ (set-macro-character #\] ']reader nil readtable)
+
+ (set-macro-character #\{ (char-name-reader '\{) nil readtable)
+
+ (set-macro-character #\} (char-name-reader '\}) nil readtable)
+
+ (set-macro-character #\# #'\#reader nil readtable)
+
+ (set-macro-character #\, (char-name-reader '\,) nil readtable)
+
+ (set-macro-character #\: #'defsymbol-reader nil readtable)
+
+ (set-macro-character #\; (char-name-reader '\;) nil readtable)
+
+ ;; (set-syntax-from-char #\/ #\" readtable)
+
+ (set-macro-character #\/ #'/reader nil readtable)
+
+ (set-syntax-from-char #\" #\a readtable)
+
+ ;; 20010301.jaa reinstated
+
+ (set-syntax-from-char #\# #\a readtable)
+
+ ;; 20010605.ms (set-syntax-from-char #\' #\" readtable)
+
+ (set-macro-character #\' '\'reader nil readtable)
+
+ ;; 20010122.jaa
+
+ (set-macro-character #\. (char-name-reader '\.) nil readtable)
+
+ ))
+
+
+
+(initialize-bnf-readtable *bnf-readtable*)
+
+
+
+
+
+(defun bnf-reader (bnf-str &aux (*readtable* *bnf-readtable*)
+
+ #+:aclpc (allegro::*read-case* :leave))
+
+ (loop with bnf-length = (length bnf-str)
+
+ with open-range
+
+ with tokens
+
+ with start = 0
+
+ if (< start bnf-length)
+
+ do
+
+ (multiple-value-bind (expr end)
+
+ (read-from-string bnf-str nil nil :start start)
+
+ ;; (print expr)
+
+ (cond ((null expr)
+
+ (return-from bnf-reader (nreverse tokens)))
+
+ ((eq expr :comment)
+
+ (setf start end))
+
+ (t
+
+ (cond ((member expr *metasymbols*)
+
+ (cond ((eq expr '\[) (setf open-range t))
+
+ ((eq expr '\]) (setf open-range nil)))
+
+ (push expr tokens))
+
+ ((stringp expr) ;; terminale
+
+ (cond ((and (> (length expr) 0) (char= (char expr 0) #\#) ;; leave non-hex as string
+
+ (not (find-if #'(lambda (c) (not (digit-char-p c 16))) expr)))
+
+ (cond (open-range
+
+ ;; Range ohne terminale delimiter
+
+ (push expr tokens))
+
+ (t (push '\' tokens)
+
+ ;; the originl pushed a number ?
+
+ ;; (push (hex-string-to-number expr) tokens)
+
+ (push (make-string 1 :initial-element (code-char (hex-string-to-number expr))) tokens)
+
+ (push '\' tokens))))
+
+ (t (push '\' tokens)
+
+ (push expr tokens)
+
+ (push '\' tokens))))
+
+ ((numberp expr)
+
+ (push (format nil "~A" expr) tokens))
+
+ (t (push (string expr) tokens)))
+
+ (setf start end))))
+
+ else return (nreverse tokens)))
+
+
+
+(defun hex-string-to-number (expr)
+
+ (let ((*readtable* *ansi-cl-readtable*))
+
+ (read-from-string expr)))
+
+
+
+(defun alternative-chars (str)
+
+ (format nil "~{'~A'~^ | ~}" (coerce str 'list)))
+
+
+
+(defun sequence-chars (str)
+
+ (format nil "~{'~A'~^ ~}" (coerce str 'list)))
+
+
+
+(defmethod hexstring ((object character))
+
+ (let ((*print-base* 16))
+
+ (format nil "#x~A" (char-code object))))
+
+
+
+#|
+
+(hexstring #\a)
+
+(alternative-chars "adfa")
+
+(sequence-chars "adf")
+
+(bnf-reader "[a b c]")
+
+(defun hex-string-to-char (expr)
+
+ (let ((*readtable* *ansi-cl-readtable*))
+
+ (code-char (read-from-string expr))))
+
+
+
+(defun read-number-string (stream char &aux (output (make-string-output-stream)))
+
+ (write-char char output)
+
+ (let ((*readtable* (copy-readtable nil)))
+
+ (set-syntax-from-char #\- #\a *readtable*)
+
+ (loop
+
+ for nc = (peek-char nil stream nil nil)
+
+ for i from 0
+
+ while (and nc (char/= nc #\] #\- #\# #\space))
+
+ do (write-char (read-char stream) output))
+
+ (get-output-stream-string output)))
+
+
+
+
+
+
+
+;; Beispiele
+
+
+
+(bnf-reader "// doc Dies
+
+s ::= /* comment */ 'a'")
+
+
+
+;; note the escaping form when evaluating tests strings ...
+
+
+
+(bnf-reader "SingleQuote ::= '\\'' ")
+
+(bnf-reader "DoubleQuote ::= '\"' ")
+
+
+
+(bnf-to-atn
+
+ (bnf-object-tree
+
+ (caar (callparser 'ebnf
+
+ (bnf-reader "root ::= cell+ cell ::= [2,3 -> 'foo']")))))
+
+
+
+(bnf-to-atn
+
+ (bnf-object-tree
+
+ (caar (callparser 'ebnf
+
+ (bnf-reader "s ::= #[print foo] [^#xd-#xh] | [^#x45#x45] | [#x45-#x65] #[print a]")))))
+
+
+
+(write-source
+
+ (bnf-to-atn
+
+ "test ::= 'a' range '.' range ::= [a-z] | [^U-Z]")
+
+ "TestParser")
+
+
+
+;;; #[print a]
+
+;;; terminal-delimiter ::= '''
+
+
+
+(bnf-object-tree
+
+ (callparser 'ebnf
+
+ (bnf-reader
+
+
+
+ "ebnf ::= definition+
+
+ definition ::= symbol defsymbol rhs
+
+
+
+ rhs ::= qexpr+ | alternative
+
+ qexpr ::= (symbol | group) occurrence?
+
+ group ::= leftpar (qexpr+ | alternative) rightpar
+
+ alternative ::= qexpr oneof (qexpr | alternative)
+
+
+
+ symbol ::= terminal | nonterminal
+
+ nonterminal ::= token
+
+ terminal ::= terminal-delimiter token terminal-delimiter
+
+
+
+ leftpar ::= '('
+
+ rightpar ::= ')'
+
+ oneof ::= '|'
+
+ defsymbol ::= '::='
+
+ occurrence ::= '+' | '*' | '?'") ) )
+
+
+
+|#
\ No newline at end of file
Modified: branches/sbcl-0.9.x-testing/code/xparser/xml-printer.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/xparser/xml-printer.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/xparser/xml-printer.lisp Tue Feb 14 11:52:41 2006
@@ -1 +1,650 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-
#|
<DOCUMENTATION>
<DESCRIPTION>
print methods for xml data models
</DESCRIPTION>
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
href='file://xml/sysdcl.lisp' />
<CHRONOLOGY>
<DELTA DATE='20010305' AUTHOR='JAA'/>
<DELTA DATE='20010511' AUTHOR='JAA'>
separate <code>WRITE-NODE</code> and <code>ENCODE-NODE</code> functions.
the first acts as the interface and takes a stream arg. the second is
internal and expects bindings for the writer function.
</DELTA>
<DELTA DATE='20010603'>
corrected (encode-node symbol) to permit uninterned names -> no prefix;
bind *document* in (write-node doc-node) for consistency parse/serialize.
</DELTA>
<DELTA DATE='20010621'>
fixed spacing in attribute declarations<br />
fixed encoding printing for doc-node</DELTA>
<DELTA DATE='20010621'>WITH-XML-WRITER macro</DELTA>
<DELTA DATE='20010623'>encode-node for doc-node takes a default doctype
name from the root element</DELTA>
<DELTA DATE='20010625'>
adjustments to encode-node for <code>*-model</code> for PCDATA
<br />
*node-cache* to support recursive <code>DEF-NODE</code> printing, which
makes it possible to effect prefixes analogous to those used in the
document entity.</DELTA>
<DELTA DATE='20010626'>
changed respective <code>WRITE-NODE</code> and <code>ENCODE-NODE</code>
to specialize on <code>ABSTRACT-ELEM-NODE</code> rather than on
<code>ELEM-NODE</code> in order to support specialized instantiation.
<code>ENCODE-NODE</code> now relies on the interface rather than the
presence of slots.
</DELTA>
<DELTA DATE='20010707'>reified <code>ENCODE-NEWLINE</code></DELTA>
<DELTA DATE='20010803'>
introduced uniform -interface specializers document, element, and property
nodes</DELTA>
<DELTA DATE='20010906'>modified <code>ENCODE-NODE</code> for name instances</DELTA>
<DELTA DATE='20010910'>fix to encode node for default namespace names</DELTA>
<DELTA DATE='20011010'>use <code>ephemeral</code> property to control printing</DELTA>
<DELTA DATE='20011219'>*generated-ns-bindings*as a special binding with
a single global handler</DELTA>
<DELTA DATE='20011223'><code>writer-stream</code></DELTA>
<DELTA DATE='20020112'>(ecode-node symbol) delegates keywords to the
string method</DELTA>
<DELTA DATE='20020118'>some CormanLisp</DELTA>
<DELTA DATE='20030320'>with-output-encoding changed to accept keyword options;
correction for generated namespace declarations in element definitions </DELTA>
<DELTA DATE='20030323'>correct default serialization for attribute definitions</DELTA>
<DELTA DATE='20030531'>corrected encode-generated-ns-bindings for string prefixes</DELTA>
<DELTA DATE='20030602'>scl</DELTA>
<DELTA DATE='20031023'>enabled prefix hint in preference to namespace nickname</DELTA>
<DELTA DATE='20040125'>fixed 20031023 to use the node rather than the name and
to guard for unbound prefix</DELTA>
<DELTA DATE='20040202'>lw-4.3-pc required a definition for stream-read-char(writer-stream)</DELTA>
<DELTA DATE='20040210'>lw-4.3.6-pc required a direction slot declaration for xml-writer when
loading fasl files</DELTA>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "XML-PARSER")
;;
;;
;; interface functions
#|
(defMacro with-xml-writer ((stream &optional (encoding :utf-8)) &rest body)
"execute the body in a context appropriate to encode xml to the
provided stream."
`(multiple-value-bind (*writer-function *writer-arg)
(encoding-stream-writer ,stream ,encoding)
(let ((*namespace-bindings* *default-namespaces*))
(handler-bind ((|NSC: Prefix Declared|
#'(lambda (condition &aux (prefix (next-prefix))
node)
(setf node (cons prefix (name condition)))
(push node *namespace-bindings*)
(push node *generated-ns-bindings*)
(use-value prefix))))
,@body))))
|#
(defun call-with-xml-writer (function *xml-output*
&key (encoding *output-encoding*)
((:pretty *print-pretty*) *print-pretty*)
; namespace-bindings
&allow-other-keys)
"execute the body in a context appropriate to encode xml to the provided stream.
this includes *default-namespaces* as the initial value for
*namespace-bindings* and a null *xml-writer-node-cache*."
(multiple-value-bind (*writer-function *writer-arg *output-encoding*)
(encoding-stream-writer *xml-output* encoding)
(let ((*namespace-bindings* *default-namespaces*))
(handler-bind ((|NSC: Namespace Declared|
;; this condition is signaled where a namespace is not bound, and thus
;; therefore no prefix is apparent for serialization.
;; if a preference is provided, this is tested to see if some other
;; namespace is already bound to it.
;; if the prefix is already in use, or if no prefix hint was provided,
;; then the 'next' one is generated. the "" prefix is handled by leaving it up to
;; prefix-namespace to observe whether default namespace bindings are visible
;; or not.
#'(lambda (condition)
(let ((namespace (condition-namespace condition))
(name (condition-name condition)))
;; if a suggestion for prefix
(when *xml-verbose*
(warn "~a with prefix hint ~a~%with ns bindings ~s" condition name
*namespace-bindings*))
(if (or name (let ((maybe-name (namespace-printname namespace)))
(when (or (equal name "")
(is-ncname maybe-name))
(setf name maybe-name))))
(handler-case (when (prefix-value name)
(setf name (next-prefix)))
(|NSC: Prefix Declared| (c)
;; if the prefix wasn't declared, then use it
(declare (ignore c))))
(setf name (next-prefix)))
(when *xml-verbose*
(warn "yielded prefix: ~s." name))
(setf (prefix-value (local-part name))
namespace
;(namespace-name namespace)
)
(push (first *namespace-bindings*) *generated-ns-bindings*)
(use-value name)))))
(funcall function)))))
(defMacro with-xml-writer ((stream &key (encoding nil)) &rest body
&aux (writer-body (gensym "WRITER-"))
(xml-stream (if (symbolp stream) stream (gensym "XML-STREAM-"))))
"ensure the the body is executed in a context appropriate for xml encoding."
`(let (,@(unless (eq xml-stream stream) `((,xml-stream ,stream))))
(flet ((,writer-body () ,@body))
(declare (dynamic-extent (function ,writer-body)))
(if (eq ,xml-stream *xml-output*)
(funcall #',writer-body)
(call-with-xml-writer #',writer-body ,xml-stream
,@(when encoding `(:encoding ,encoding)))))))
(defun encode-format (&rest args)
(apply #'format *xml-writer-stream* args))
(defClass writer-stream (#+ALLEGRO excl::fundamental-binary-output-stream
#+LispWorks stream:fundamental-stream
#+digitool ccl::output-binary-stream
#+openmcl fundamental-binary-output-stream
#+CormanLisp stream)
(#+(or clisp CMU lispworks sbcl scl) (direction :initarg :direction))
(:default-initargs :direction :output
#+CormanLisp :element-type #+CormanLisp 'unsigned-byte))
#+allegro
(defMethod excl:stream-line-column ((stream writer-stream)) nil)
#+lispworks
(defmethod stream:stream-write-char ((stream writer-stream) (char character))
(funcall *writer-function *writer-arg char))
(defMethod stream-tyo ((stream writer-stream) char)
(funcall *writer-function *writer-arg char))
(defMethod stream-element-type ((stream writer-stream))
'character)
(setq *xml-writer-stream* (make-instance 'writer-stream))
(defGeneric write-node (datum stream &rest args)
(:documentation
"encode the node as xml to the provided stream.")
(:method ((node t) (destination pathname) &rest args)
(with-open-file (stream destination :direction :output :element-type 'unsigned-byte
:if-exists :supersede :if-does-not-exist :create)
(apply #'write-node node stream args)))
(:method ((node t) (*output-destination* t) &rest args)
(apply #'call-with-xml-writer
#'(lambda () (encode-node node))
*output-destination*
args)
node))
#+digitool
(progn
(pushnew '(with-xml-writer . 1) *FRED-SPECIAL-INDENT-ALIST* :key #'first)
nil)
;;
;;
;; primitives
(defun encode-char (char)
"encode the provided character to the current output destination."
(funcall *writer-function *writer-arg char))
(defun encode-string (string)
"encode the provided string to the output destination.
used when it is known that no escapes are necessary."
(dotimes (i (length string))
(funcall *writer-function *writer-arg (char string i))))
(defun encode-newline ()
"emit a newline to the output destination."
(encode-char #.(code-char #x0a)))
(defGeneric encode-node (node)
(:documentation
"encode the provided node to the current output destination.
perform a tree walk for linked nodes.
escape character data in content and attribute values as appropriate.
introduce namespace bindings as required."))
(defMethod encode-node
((string string) &aux char)
(dotimes (x (length string))
(setf char (char string x))
(case char
(#\< (encode-string "<"))
(#\> (encode-string ">"))
(#\&
; here an attempt to both escape and not
(if (position #\; string :start x)
(funcall *writer-function *writer-arg char)
(encode-string "&")))
(t (funcall *writer-function *writer-arg char)))))
(defMethod encode-node
((node list))
(mapc #'encode-node node))
(defmethod encode-node
((node number))
(encode-node (write-to-string node)))
;;
;;
;; node methods
(defMethod encode-node
((node symbol)
&aux (name (local-part node))
(namespace (namespace node))
prefix)
(if (keywordp node)
(encode-node (string node))
(cond ((string= (namespace-name namespace) *xmlns-prefix-namestring*)
(encode-string *xmlns-prefix-namestring*)
(unless (eq node *default-namespace-attribute-name*)
(encode-char #\:)
(encode-node name)))
(namespace
(setf prefix (local-part (namespace-prefix namespace (get node :prefix))))
(unless (string= prefix "")
(encode-node (local-part prefix))
(encode-char #\:))
(encode-node name))
(t ;; allow uninterned names
(encode-node name)))))
(defMethod encode-node
((node null))
)
(defMethod encode-node
((node abstract-name)
&aux (name (local-part node))
(namespace (namespace node))
prefix)
(cond ((string= (namespace-name namespace) *xmlns-prefix-namestring*)
(encode-string *xmlns-prefix-namestring*)
(unless (eq node *default-namespace-attribute-name*)
(encode-char #\:)
(encode-node name)))
(namespace
(setf prefix (local-part (namespace-prefix namespace
(with-slots (prefix) node
(and (slot-boundp node 'prefix) prefix)))))
(unless (string= prefix "")
(encode-node (local-part prefix))
(encode-char #\:))
(encode-node name))
(t ;; allow uninterned names
(encode-node name))))
(defMethod encode-node
((node doc-node-interface)
&aux
(*prefix-count* *prefix-count*)
(*namespace-bindings* *namespace-bindings*)
(*default-namespace* *default-namespace*)
(name nil)
(encoding (encoding node))
(standalone (standalone node))
(version (version node)))
(encode-string "<?xml")
(when (zerop (length version))
(setf version *xml-version*))
(encode-string " version='")
(encode-string version)
(encode-char #\')
(when encoding
(encode-string " encoding='")
(encode-string (string encoding))
(encode-char #\'))
(encode-string " standalone='")
(encode-string (if standalone "yes" "no"))
(encode-string "' ?>")
(setf name (name (entity-info node)))
(when (or (eq name *null-name*) (null name))
(setf name (name (root node))))
(when (or (plusp (hash-table-count (notations node)))
(> (hash-table-count (general-entities node)) 5)
(plusp (hash-table-count (parameter-entities node)))
(plusp (hash-table-count (types node)))
(attributes node))
(encode-char #\newline)
(encode-string "<!DOCTYPE ")
(encode-node (local-part name)) ;; force the literal name w/o ns|prefix
(encode-string " [")
(flet ((encode-def (key def)
(declare (ignore key))
(encode-newline)
(encode-node def)))
(maphash #'encode-def (notations node))
(maphash #'encode-def (parameter-entities node))
(maphash #'encode-def (general-entities node)))
(let* ((root (root node))
(root-type (when root (ignore-errors (def root))))
(*node-cache* nil))
(flet ((encode-def (key def)
(declare (ignore key))
(unless (find def *node-cache*)
(push def *node-cache*)
(encode-newline)
(encode-node def))))
;; encode the root definition first. the method proceeds recursively,
;; which generates sensible namespace prefixes. any remaining
;; definitions are done subsequently
(if root-type
(encode-def nil root-type)
(encode-string " <!-- no root element definition present -->"))
(maphash #'encode-def (types node))))
(encode-newline)
(encode-string " ]>"))
(dolist (child (children node))
(encode-newline)
(encode-node child)))
(defun encode-generated-ns-bindings (generated-ns-bindings)
(dolist (binding generated-ns-bindings)
(destructuring-bind (prefix . namespace) binding
(encode-char #\space)
(typecase prefix
(name (encode-node prefix))
(string
(encode-string "xmlns")
(unless (equal prefix "")
(encode-char #\:)
(encode-string prefix))))
(encode-char #\=)
(encode-char #\')
(encode-node (namespace-name namespace))
(encode-char #\'))))
(defMethod encode-node
((node elem-node-interface))
(let ((*namespace-bindings* *namespace-bindings*)
(*default-namespace* *default-namespace*)
(*node-level* (1+ *node-level*))
(*prefix-count* *prefix-count*)
(*generated-ns-bindings* nil))
(declare (dynamic-extent *namespace-bindings*))
(with-accessors ((name name)
(children children)
(attributes attributes)
(namespaces namespaces)) node
(dolist (ns-node namespaces)
(push ns-node *namespace-bindings*))
; (break "namespaces: ~s/~s." *namespace-bindings* namespaces)
(encode-char #\<)
(encode-node name)
(dolist (node namespaces)
(encode-char #\space)
(encode-node node))
(dolist (node attributes)
(encode-char #\space)
(encode-node node))
(when *generated-ns-bindings*
(encode-generated-ns-bindings *generated-ns-bindings*))
(cond (children
(encode-char #\>)
(dolist (node children)
(when *print-pretty*
(encode-newline)
(dotimes (x *node-level*) (encode-char #\space)))
(encode-node node))
(encode-string "</")
(encode-node name)
(encode-char #\>))
(t
(encode-string " />"))))))
(defMethod encode-node
((node elem-property-node-interface))
(with-slots (name children) node
(encode-node name)
(encode-char #\=)
(encode-char #\')
(dolist (node children)
(encode-node node))
(encode-char #\')))
(defmethod encode-node
((node pi-node))
(encode-string "<?")
(encode-node (name node))
(encode-char #\space)
(dolist (node (children node))
(encode-node node))
(encode-string "?>"))
(defMethod encode-node
((node comment-node))
(encode-string "<!-- ")
(dolist (node (children node))
(encode-node node))
(encode-string " -->"))
;;
;;
;; declarations
(defMethod encode-node ((node def-elem-type)
&aux
(*namespace-bindings* *namespace-bindings*)
(*generated-ns-bindings* nil)
c-def)
(with-slots (name children properties) node
;; first do the definition itself, that is, the content model and the
;; attribute declarations. these all in the same namespace context
(dolist (node properties)
(when (is-ns-node (prototype node))
(push (prototype node) *namespace-bindings*)))
;; write the element declaration
(encode-string " <!ELEMENT ")
(encode-node name)
(encode-char #\space)
(encode-node children)
(encode-string " >")
;; write the attribute declarations
(when properties
(encode-newline)
(encode-string " <!ATTLIST ")
(encode-node name)
(encode-char #\space)
(mapc #'(lambda (n)
(encode-newline)
(encode-string " ")
(encode-node n))
properties)
(encode-string " >"))
(when *generated-ns-bindings*
(encode-newline)
(encode-string " <!ATTLIST ")
(encode-node name)
(encode-char #\space)
(dolist (binding *generated-ns-bindings*)
(destructuring-bind (prefix . namespace) binding
(encode-newline)
(encode-string " ")
(typecase prefix
(string (encode-string "xmlns:") (encode-string prefix))
(t (encode-node (first binding))))
(encode-string " CDATA '")
(encode-string (namespace-name namespace))
(encode-string "'")))
(encode-string " >"))
;; then do type definitions referenced by virtue of their presence in the
;; content model
(dolist (c-name (collect-model-names (first (bnfp::bnf-rhs (model node)))))
(cond ((eq c-name *empty-name*) nil)
((eq c-name *wild-name*) nil)
((setf c-def (find-def-elem-type c-name (document node)))
(unless (find c-def *node-cache*)
(push c-def *node-cache*)
(encode-newline)
(encode-node c-def)))
(t
(encode-string
(format nil " <!-- definition not found: ~a: ~a."
(name node) c-name)))))))
(defMethod encode-node ((node |content-model|))
(encode-node (first (bnfp::bnf-rhs node))))
(defMethod encode-node ((node |\|-content|)
&aux (expressions (bnfp::bnf-expressions node)))
(encode-char #\()
(loop (encode-node (pop expressions))
(if expressions (encode-string " | ") (return)))
(encode-char #\)))
(defMethod encode-node ((node |?-content|))
(encode-node (bnfp::bnf-expression node))
(encode-char #\?))
(defMethod encode-node ((node |*-content|)
&aux (expression (bnfp::bnf-expression node))
name)
(setf name
(when (typep expression '|content-name|) (bnfp::bnf-name expression)))
(cond ((eq name *wild-name*) (encode-string "ANY"))
((eq name *empty-name*) (encode-string "EMPTY"))
((eq name *mixed-name*) (encode-string "(#PCDATA)"))
(t (encode-node expression)
(encode-char #\*))))
(defMethod encode-node ((node |+-content|))
(encode-node (bnfp::bnf-expression node))
(encode-char #\+))
(defMethod encode-node ((node |content|))
(encode-node (bnfp::bnf-expression node)))
(defMethod encode-node ((node |,-content|)
&aux (expressions (bnfp::bnf-expressions node)))
(encode-char #\()
(loop (encode-node (pop expressions))
(if expressions (encode-string ", ") (return)))
(encode-char #\)))
(defMethod encode-node ((node |content-name|)
&aux (name (bnfp::bnf-name node)))
(cond ((eq name *mixed-name*) (encode-string "(#PCDATA)"))
(t (encode-node (bnfp::bnf-name node)))))
(defMethod encode-node ((node |type-name|))
(encode-node (bnfp::bnf-name node)))
;; this isn't complete, but it's a start
(defMethod encode-node ((node def-elem-property-type)
&aux (prototype (prototype node))
(default (children prototype))
(stipulation (stipulation node)))
(flet ((encode-enumeration (enumeration)
(cond (enumeration
(encode-char #\()
(loop (encode-node (pop enumeration))
(if enumeration (encode-char #\|) (return)))
(encode-char #\)))
(t
(encode-string "()")))))
(unless (is-ephemeral node)
(encode-node (name node))
(typecase prototype
(entity-attr-node (encode-string " ENTITY"))
(entities-attr-node (encode-string " ENTITIES"))
(enumeration-attr-node
(encode-char #\space)
(encode-enumeration (children node)))
(id-attr-node (encode-string " ID"))
(id-ref-attr-node (encode-string " IDREF"))
(id-refs-attr-node (encode-string " IDREFS"))
(nmtoken-attr-node (encode-string " NMTOKEN"))
(nmtokens-attr-node (encode-string " NMTOKENS"))
(notation-attr-node
(encode-string " NOTATION")
(encode-enumeration (children node)))
(ns-node (encode-string " CDATA"))
(attr-node (encode-string " CDATA"))
)
(encode-char #\space)
(ecase stipulation
(:required (encode-string "#REQUIRED"))
(:implied (encode-string "#IMPLIED"))
((nil :fixed)
(when (eq stipulation :fixed) (encode-string "#FIXED"))
(encode-char #\space)
(encode-char #\')
(when default (encode-node default))
(encode-char #\'))))))
(defMethod encode-node ((node def-notation))
(with-slots (name system-id public-id) node
(encode-string " <!NOTATION " )
(encode-node name)
(encode-char #\space)
(cond (public-id
(encode-string "PUBLIC '")
(encode-string public-id)
(when system-id
(encode-string "' '")
(encode-string system-id)))
(t
(encode-string "SYSTEM '")
(encode-string system-id)))
(encode-string "' >")))
(defMethod encode-node ((node ref-entity))
(with-slots (value children) node
(flet ((encode-char-or-byte (datum)
(funcall *writer-function *writer-arg
(if (integerp datum) (code-char datum) datum))))
(cond ((and (expand node)
(cond ((stringp value) (map nil #'encode-char value) t)
((functionp value)
(map nil #'encode-char-or-byte (funcall value))
t)
((is-def-internal-entity value)
(with-slots (children value) value
(cond (children
(map nil #'encode-char-or-byte children)
t)
(value
(map nil #'encode-char value)
t))))
((typep children 'sequence)
(map nil #'encode-char-or-byte children)))))
(t
(encode-char #\&)
(encode-node (name node))
(encode-char #\;))))))
(defMethod encode-node ((node def-internal-entity))
(encode-string " <!ENTITY ")
(when (is-def-parameter-entity node)
(encode-string "% "))
(encode-node (name node))
(encode-string " '")
(with-slots (children value) node
(cond (children
(mapc #'(lambda (byte) (funcall *writer-function *writer-arg
(code-char byte)))
children))
(value
(map nil #'encode-char value))))
(encode-string "' >"))
(defMethod encode-node ((node def-external-entity))
(encode-string " <!ENTITY ")
(when (is-def-parameter-entity node)
(encode-string "% "))
(encode-node (name node))
(let ((system (system-id node))
(public (public-id node)))
(cond (public (encode-string " PUBLIC '")
(encode-node public)
(encode-string "' '")
(encode-node system)
(encode-node "'"))
(system (encode-string " SYSTEM '")
(encode-node system)
(encode-node "'"))))
(encode-string " >"))
:EOF
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-
+
+#|
+<DOCUMENTATION>
+ <DESCRIPTION>
+ print methods for xml data models
+ </DESCRIPTION>
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+ href='file://xml/sysdcl.lisp' />
+ <CHRONOLOGY>
+ <DELTA DATE='20010305' AUTHOR='JAA'/>
+ <DELTA DATE='20010511' AUTHOR='JAA'>
+ separate <code>WRITE-NODE</code> and <code>ENCODE-NODE</code> functions.
+ the first acts as the interface and takes a stream arg. the second is
+ internal and expects bindings for the writer function.
+ </DELTA>
+ <DELTA DATE='20010603'>
+ corrected (encode-node symbol) to permit uninterned names -> no prefix;
+ bind *document* in (write-node doc-node) for consistency parse/serialize.
+ </DELTA>
+ <DELTA DATE='20010621'>
+ fixed spacing in attribute declarations<br />
+ fixed encoding printing for doc-node</DELTA>
+ <DELTA DATE='20010621'>WITH-XML-WRITER macro</DELTA>
+ <DELTA DATE='20010623'>encode-node for doc-node takes a default doctype
+ name from the root element</DELTA>
+ <DELTA DATE='20010625'>
+ adjustments to encode-node for <code>*-model</code> for PCDATA
+ <br />
+ *node-cache* to support recursive <code>DEF-NODE</code> printing, which
+ makes it possible to effect prefixes analogous to those used in the
+ document entity.</DELTA>
+ <DELTA DATE='20010626'>
+ changed respective <code>WRITE-NODE</code> and <code>ENCODE-NODE</code>
+ to specialize on <code>ABSTRACT-ELEM-NODE</code> rather than on
+ <code>ELEM-NODE</code> in order to support specialized instantiation.
+ <code>ENCODE-NODE</code> now relies on the interface rather than the
+ presence of slots.
+ </DELTA>
+ <DELTA DATE='20010707'>reified <code>ENCODE-NEWLINE</code></DELTA>
+ <DELTA DATE='20010803'>
+ introduced uniform -interface specializers document, element, and property
+ nodes</DELTA>
+ <DELTA DATE='20010906'>modified <code>ENCODE-NODE</code> for name instances</DELTA>
+ <DELTA DATE='20010910'>fix to encode node for default namespace names</DELTA>
+ <DELTA DATE='20011010'>use <code>ephemeral</code> property to control printing</DELTA>
+ <DELTA DATE='20011219'>*generated-ns-bindings*as a special binding with
+ a single global handler</DELTA>
+ <DELTA DATE='20011223'><code>writer-stream</code></DELTA>
+ <DELTA DATE='20020112'>(ecode-node symbol) delegates keywords to the
+ string method</DELTA>
+ <DELTA DATE='20020118'>some CormanLisp</DELTA>
+ <DELTA DATE='20030320'>with-output-encoding changed to accept keyword options;
+ correction for generated namespace declarations in element definitions </DELTA>
+ <DELTA DATE='20030323'>correct default serialization for attribute definitions</DELTA>
+ </CHRONOLOGY>
+ </DOCUMENTATION>
+|#
+
+(in-package "XML-PARSER")
+
+
+;;
+;;
+;; interface functions
+
+#|
+(defMacro with-xml-writer ((stream &optional (encoding :utf-8)) &rest body)
+ "execute the body in a context appropriate to encode xml to the
+ provided stream."
+ `(multiple-value-bind (*writer-function *writer-arg)
+ (encoding-stream-writer ,stream ,encoding)
+ (let ((*namespace-bindings* *default-namespaces*))
+ (handler-bind ((|NSC: Prefix Declared|
+ #'(lambda (condition &aux (prefix (next-prefix))
+ node)
+ (setf node (cons prefix (name condition)))
+ (push node *namespace-bindings*)
+ (push node *generated-ns-bindings*)
+ (use-value prefix))))
+ ,@body))))
+|#
+
+(defun call-with-xml-writer (function *xml-output*
+ &key (encoding *output-encoding*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ; namespace-bindings
+ &allow-other-keys)
+ "execute the body in a context appropriate to encode xml to the provided stream.
+ this includes *default-namespaces* as the initial value for
+ *namespace-bindings* and a null *xml-writer-node-cache*."
+ (multiple-value-bind (*writer-function *writer-arg *output-encoding*)
+ (encoding-stream-writer *xml-output* encoding)
+ (let ((*namespace-bindings* *default-namespaces*))
+ (handler-bind ((|NSC: Namespace Declared|
+ ;; this condition is signaled where a namespace is not bound, and thus
+ ;; therefore no prefix is apparent for serialization.
+ ;; if a preference is provided, this is tested to see if some other
+ ;; namespace is already bound to it.
+ ;; if the prefix is already in use, or if no prefix hint was provided,
+ ;; then the 'next' one is generated. the "" prefix is handled by leaving it up to
+ ;; prefix-namespace to observe whether default namespace bindings are visible
+ ;; or not.
+ #'(lambda (condition)
+ (let ((namespace (condition-namespace condition))
+ (name (condition-name condition)))
+ ;; if a suggestion for prefix
+ (when *xml-verbose*
+ (warn "~a with prefix hint ~a~%with ns bindings ~s" condition name
+ *namespace-bindings*))
+ (if (or name (let ((maybe-name (namespace-printname namespace)))
+ (when (or (equal name "")
+ (is-ncname maybe-name))
+ (setf name maybe-name))))
+ (handler-case (when (prefix-value name)
+ (setf name (next-prefix)))
+ (|NSC: Prefix Declared| (c)
+ ;; if the prefix wasn't declared, then use it
+ (declare (ignore c))))
+ (setf name (next-prefix)))
+ (when *xml-verbose*
+ (warn "yielded prefix: ~s." name))
+ (setf (prefix-value (local-part name))
+ namespace
+ ;(namespace-name namespace)
+ )
+ (push (first *namespace-bindings*) *generated-ns-bindings*)
+ (use-value name)))))
+ (funcall function)))))
+
+
+(defMacro with-xml-writer ((stream &key (encoding nil)) &rest body
+ &aux (writer-body (gensym "WRITER-"))
+ (xml-stream (if (symbolp stream) stream (gensym "XML-STREAM-"))))
+ "ensure the the body is executed in a context appropriate for xml encoding."
+ `(let (,@(unless (eq xml-stream stream) `((,xml-stream ,stream))))
+ (flet ((,writer-body () ,@body))
+ (declare (dynamic-extent (function ,writer-body)))
+ (if (eq ,xml-stream *xml-output*)
+ (funcall #',writer-body)
+ (call-with-xml-writer #',writer-body ,xml-stream
+ ,@(when encoding `(:encoding ,encoding)))))))
+
+
+(defun encode-format (&rest args)
+ (apply #'format *xml-writer-stream* args))
+
+(defClass writer-stream (#+ALLEGRO excl::fundamental-binary-output-stream
+ #+LispWorks stream:fundamental-stream
+ #+digitool ccl::output-binary-stream
+ #+openmcl fundamental-binary-output-stream
+ #+CormanLisp stream)
+ (#+(or cmu sbcl) (direction :initarg :direction))
+ (:default-initargs :direction :output
+ #+CormanLisp :element-type #+CormanLisp 'unsigned-byte))
+
+
+
+(defMethod stream-tyo ((stream writer-stream) char)
+ (funcall *writer-function *writer-arg char))
+
+(defMethod stream-element-type ((stream writer-stream))
+ 'character)
+
+(setq *xml-writer-stream* (make-instance 'writer-stream))
+
+(defGeneric write-node (datum stream &rest args)
+ (:documentation
+ "encode the node as xml to the provided stream.")
+ (:method ((node t) (destination pathname) &rest args)
+ (with-open-file (stream destination :direction :output :element-type 'unsigned-byte
+ :if-exists :supersede :if-does-not-exist :create)
+ (apply #'write-node node stream args)))
+ (:method ((node t) (*output-destination* t) &rest args)
+ (apply #'call-with-xml-writer
+ #'(lambda () (encode-node node))
+ *output-destination*
+ args)
+ node))
+
+#+digitool
+(progn
+ (pushnew '(with-xml-writer . 1) *FRED-SPECIAL-INDENT-ALIST* :key #'first)
+ nil)
+
+
+;;
+;;
+;; primitives
+
+(defun encode-char (char)
+ "encode the provided character to the current output destination."
+ (funcall *writer-function *writer-arg char))
+
+(defun encode-string (string)
+ "encode the provided string to the output destination.
+ used when it is known that no escapes are necessary."
+ (dotimes (i (length string))
+ (funcall *writer-function *writer-arg (char string i))))
+
+(defun encode-newline ()
+ "emit a newline to the output destination."
+ (encode-char #.(code-char #x0a)))
+
+(defGeneric encode-node (node)
+ (:documentation
+ "encode the provided node to the current output destination.
+ perform a tree walk for linked nodes.
+ escape character data in content and attribute values as appropriate.
+ introduce namespace bindings as required."))
+
+(defMethod encode-node
+ ((string string) &aux char)
+ (dotimes (x (length string))
+ (setf char (char string x))
+ (case char
+ (#\< (encode-string "<"))
+ (#\> (encode-string ">"))
+ (#\&
+ ; here an attempt to both escape and not
+ (if (position #\; string :start x)
+ (funcall *writer-function *writer-arg char)
+ (encode-string "&")))
+ (t (funcall *writer-function *writer-arg char)))))
+
+(defMethod encode-node
+ ((node list))
+ (mapc #'encode-node node))
+
+(defmethod encode-node
+ ((node number))
+ (encode-node (write-to-string node)))
+
+;;
+;;
+;; node methods
+
+(defMethod encode-node
+ ((node symbol)
+ &aux (name (local-part node))
+ (namespace (namespace node))
+ prefix)
+ (if (keywordp node)
+ (encode-node (string node))
+ (cond ((string= (namespace-name namespace) *xmlns-prefix-namestring*)
+ (encode-string *xmlns-prefix-namestring*)
+ (unless (eq node *default-namespace-attribute-name*)
+ (encode-char #\:)
+ (encode-node name)))
+ (namespace
+ (setf prefix (local-part (namespace-prefix namespace)))
+ (unless (string= prefix "")
+ (encode-node (local-part prefix))
+ (encode-char #\:))
+ (encode-node name))
+ (t ;; allow uninterned names
+ (encode-node name)))))
+
+(defMethod encode-node
+ ((node null))
+ )
+
+(defMethod encode-node
+ ((node abstract-name)
+ &aux (name (local-part node))
+ (namespace (namespace node))
+ prefix)
+ (cond ((string= (namespace-name namespace) *xmlns-prefix-namestring*)
+ (encode-string *xmlns-prefix-namestring*)
+ (unless (eq node *default-namespace-attribute-name*)
+ (encode-char #\:)
+ (encode-node name)))
+ (namespace
+ (setf prefix (local-part (namespace-prefix namespace)))
+ (unless (string= prefix "")
+ (encode-node (local-part prefix))
+ (encode-char #\:))
+ (encode-node name))
+ (t ;; allow uninterned names
+ (encode-node name))))
+
+(defMethod encode-node
+ ((node doc-node-interface)
+ &aux
+ (*prefix-count* *prefix-count*)
+ (*namespace-bindings* *namespace-bindings*)
+ (*default-namespace* *default-namespace*)
+ (name nil)
+ (encoding (encoding node))
+ (standalone (standalone node))
+ (version (version node)))
+ (encode-string "<?xml")
+ (when (zerop (length version))
+ (setf version *xml-version*))
+ (encode-string " version='")
+ (encode-string version)
+ (encode-char #\')
+ (when encoding
+ (encode-string " encoding='")
+ (encode-string (string encoding))
+ (encode-char #\'))
+ (encode-string " standalone='")
+ (encode-string (if standalone "yes" "no"))
+ (encode-string "' ?>")
+ (setf name (name (entity-info node)))
+ (when (or (eq name *null-name*) (null name))
+ (setf name (name (root node))))
+ (when (or (plusp (hash-table-count (notations node)))
+ (> (hash-table-count (general-entities node)) 5)
+ (plusp (hash-table-count (parameter-entities node)))
+ (plusp (hash-table-count (types node)))
+ (attributes node))
+ (encode-char #\newline)
+ (encode-string "<!DOCTYPE ")
+ (encode-node (local-part name)) ;; force the literal name w/o ns|prefix
+ (encode-string " [")
+ (flet ((encode-def (key def)
+ (declare (ignore key))
+ (encode-newline)
+ (encode-node def)))
+ (maphash #'encode-def (notations node))
+ (maphash #'encode-def (parameter-entities node))
+ (maphash #'encode-def (general-entities node)))
+ (let* ((root (root node))
+ (root-type (when root (ignore-errors (def root))))
+ (*node-cache* nil))
+ (flet ((encode-def (key def)
+ (declare (ignore key))
+ (unless (find def *node-cache*)
+ (push def *node-cache*)
+ (encode-newline)
+ (encode-node def))))
+ ;; encode the root definition first. the method proceeds recursively,
+ ;; which generates sensible namespace prefixes. any remaining
+ ;; definitions are done subsequently
+ (if root-type
+ (encode-def nil root-type)
+ (encode-string " <!-- no root element definition present -->"))
+ (maphash #'encode-def (types node))))
+ (encode-newline)
+ (encode-string " ]>"))
+ (dolist (child (children node))
+ (encode-newline)
+ (encode-node child)))
+
+(defun encode-generated-ns-bindings (generated-ns-bindings)
+ (dolist (binding generated-ns-bindings)
+ (encode-char #\space)
+ (encode-node (first binding))
+ (encode-char #\=)
+ (encode-char #\')
+ (encode-node (namespace-name (rest binding)))
+ (encode-char #\')))
+
+(defMethod encode-node
+ ((node elem-node-interface))
+ (let ((*namespace-bindings* *namespace-bindings*)
+ (*default-namespace* *default-namespace*)
+ (*node-level* (1+ *node-level*))
+ (*prefix-count* *prefix-count*)
+ (*generated-ns-bindings* nil))
+ (declare (dynamic-extent *namespace-bindings*))
+ (with-accessors ((name name)
+ (children children)
+ (attributes attributes)
+ (namespaces namespaces)) node
+ (dolist (ns-node namespaces)
+ (push ns-node *namespace-bindings*))
+ ; (break "namespaces: ~s/~s." *namespace-bindings* namespaces)
+ (encode-char #\<)
+ (encode-node name)
+ (dolist (node namespaces)
+ (encode-char #\space)
+ (encode-node node))
+ (dolist (node attributes)
+ (encode-char #\space)
+ (encode-node node))
+ (when *generated-ns-bindings*
+ (encode-generated-ns-bindings *generated-ns-bindings*))
+ (cond (children
+ (encode-char #\>)
+ (dolist (node children)
+ (when *print-pretty*
+ (encode-newline)
+ (dotimes (x *node-level*) (encode-char #\space)))
+ (encode-node node))
+ (encode-string "</")
+ (encode-node name)
+ (encode-char #\>))
+ (t
+ (encode-string " />"))))))
+
+(defMethod encode-node
+ ((node elem-property-node-interface))
+ (with-slots (name children) node
+ (encode-node name)
+ (encode-char #\=)
+ (encode-char #\')
+ (dolist (node children)
+ (encode-node node))
+ (encode-char #\')))
+
+(defmethod encode-node
+ ((node pi-node))
+ (encode-string "<?")
+ (encode-node (name node))
+ (encode-char #\space)
+ (dolist (node (children node))
+ (encode-node node))
+ (encode-string "?>"))
+
+(defMethod encode-node
+ ((node comment-node))
+ (encode-string "<!-- ")
+ (dolist (node (children node))
+ (encode-node node))
+ (encode-string " -->"))
+
+;;
+;;
+;; declarations
+
+(defMethod encode-node ((node def-elem-type)
+ &aux
+ (*namespace-bindings* *namespace-bindings*)
+ (*generated-ns-bindings* nil)
+ c-def)
+ (with-slots (name children properties) node
+ ;; first do the definition itself, that is, the content model and the
+ ;; attribute declarations. these all in the same namespace context
+ (dolist (node properties)
+ (when (is-ns-node (prototype node))
+ (push (prototype node) *namespace-bindings*)))
+ ;; write the element declaration
+ (encode-string " <!ELEMENT ")
+ (encode-node name)
+ (encode-char #\space)
+ (encode-node children)
+ (encode-string " >")
+ ;; write the attribute declarations
+ (when properties
+ (encode-newline)
+ (encode-string " <!ATTLIST ")
+ (encode-node name)
+ (encode-char #\space)
+ (mapc #'(lambda (n)
+ (encode-newline)
+ (encode-string " ")
+ (encode-node n))
+ properties)
+ (encode-string " >"))
+ (when *generated-ns-bindings*
+ (encode-newline)
+ (encode-string " <!ATTLIST ")
+ (encode-node name)
+ (encode-char #\space)
+ (dolist (binding *generated-ns-bindings*)
+ (destructuring-bind (prefix . namespace) binding
+ (encode-newline)
+ (encode-string " ")
+ (typecase prefix
+ (string (encode-string "xmlns:") (encode-string prefix))
+ (t (encode-node (first binding))))
+ (encode-string " CDATA '")
+ (encode-string (namespace-name namespace))
+ (encode-string "'")))
+ (encode-string " >"))
+ ;; then do type definitions referenced by virtue of their presence in the
+ ;; content model
+ (dolist (c-name (collect-model-names (first (bnfp::bnf-rhs (model node)))))
+ (cond ((eq c-name *empty-name*) nil)
+ ((eq c-name *wild-name*) nil)
+ ((setf c-def (find-def-elem-type c-name (document node)))
+ (unless (find c-def *node-cache*)
+ (push c-def *node-cache*)
+ (encode-newline)
+ (encode-node c-def)))
+ (t
+ (encode-string
+ (format nil " <!-- definition not found: ~a: ~a."
+ (name node) c-name)))))))
+
+(defMethod encode-node ((node |content-model|))
+ (encode-node (first (bnfp::bnf-rhs node))))
+
+(defMethod encode-node ((node |\|-content|)
+ &aux (expressions (bnfp::bnf-expressions node)))
+ (encode-char #\()
+ (loop (encode-node (pop expressions))
+ (if expressions (encode-string " | ") (return)))
+ (encode-char #\)))
+
+(defMethod encode-node ((node |?-content|))
+ (encode-node (bnfp::bnf-expression node))
+ (encode-char #\?))
+
+(defMethod encode-node ((node |*-content|)
+ &aux (expression (bnfp::bnf-expression node))
+ name)
+ (setf name
+ (when (typep expression '|content-name|) (bnfp::bnf-name expression)))
+ (cond ((eq name *wild-name*) (encode-string "ANY"))
+ ((eq name *empty-name*) (encode-string "EMPTY"))
+ ((eq name *mixed-name*) (encode-string "(#PCDATA)"))
+ (t (encode-node expression)
+ (encode-char #\*))))
+
+(defMethod encode-node ((node |+-content|))
+ (encode-node (bnfp::bnf-expression node))
+ (encode-char #\+))
+
+(defMethod encode-node ((node |content|))
+ (encode-node (bnfp::bnf-expression node)))
+
+(defMethod encode-node ((node |,-content|)
+ &aux (expressions (bnfp::bnf-expressions node)))
+ (encode-char #\()
+ (loop (encode-node (pop expressions))
+ (if expressions (encode-string ", ") (return)))
+ (encode-char #\)))
+
+(defMethod encode-node ((node |content-name|)
+ &aux (name (bnfp::bnf-name node)))
+ (cond ((eq name *mixed-name*) (encode-string "(#PCDATA)"))
+ (t (encode-node (bnfp::bnf-name node)))))
+
+(defMethod encode-node ((node |type-name|))
+ (encode-node (bnfp::bnf-name node)))
+
+
+;; this isn't complete, but it's a start
+
+(defMethod encode-node ((node def-elem-property-type)
+ &aux (prototype (prototype node))
+ (default (children prototype))
+ (stipulation (stipulation node)))
+ (flet ((encode-enumeration (enumeration)
+ (cond (enumeration
+ (encode-char #\()
+ (loop (encode-node (pop enumeration))
+ (if enumeration (encode-char #\|) (return)))
+ (encode-char #\)))
+ (t
+ (encode-string "()")))))
+ (unless (is-ephemeral node)
+ (encode-node (name node))
+ (typecase prototype
+ (entity-attr-node (encode-string " ENTITY"))
+ (entities-attr-node (encode-string " ENTITIES"))
+ (enumeration-attr-node
+ (encode-char #\space)
+ (encode-enumeration (children node)))
+ (id-attr-node (encode-string " ID"))
+ (id-ref-attr-node (encode-string " IDREF"))
+ (id-refs-attr-node (encode-string " IDREFS"))
+ (nmtoken-attr-node (encode-string " NMTOKEN"))
+ (nmtokens-attr-node (encode-string " NMTOKENS"))
+ (notation-attr-node
+ (encode-string " NOTATION")
+ (encode-enumeration (children node)))
+ (ns-node (encode-string " CDATA"))
+ (attr-node (encode-string " CDATA"))
+ )
+ (encode-char #\space)
+ (ecase stipulation
+ (:required (encode-string "#REQUIRED"))
+ (:implied (encode-string "#IMPLIED"))
+ ((nil :fixed)
+ (when (eq stipulation :fixed) (encode-string "#FIXED"))
+ (encode-char #\space)
+ (encode-char #\')
+ (when default (encode-node default))
+ (encode-char #\'))))))
+
+
+(defMethod encode-node ((node def-notation))
+ (with-slots (name system-id public-id) node
+ (encode-string " <!NOTATION " )
+ (encode-node name)
+ (encode-char #\space)
+ (cond (public-id
+ (encode-string "PUBLIC '")
+ (encode-string public-id)
+ (when system-id
+ (encode-string "' '")
+ (encode-string system-id)))
+ (t
+ (encode-string "SYSTEM '")
+ (encode-string system-id)))
+ (encode-string "' >")))
+
+(defMethod encode-node ((node ref-entity))
+ (with-slots (value children) node
+ (flet ((encode-char-or-byte (datum)
+ (funcall *writer-function *writer-arg
+ (if (integerp datum) (code-char datum) datum))))
+ (cond ((and (expand node)
+ (cond ((stringp value) (map nil #'encode-char value) t)
+ ((functionp value)
+ (map nil #'encode-char-or-byte (funcall value))
+ t)
+ ((is-def-internal-entity value)
+ (with-slots (children value) value
+ (cond (children
+ (map nil #'encode-char-or-byte children)
+ t)
+ (value
+ (map nil #'encode-char value)
+ t))))
+ ((typep children 'sequence)
+ (map nil #'encode-char-or-byte children)))))
+ (t
+ (encode-char #\&)
+ (encode-node (name node))
+ (encode-char #\;))))))
+
+(defMethod encode-node ((node def-internal-entity))
+ (encode-string " <!ENTITY ")
+ (when (is-def-parameter-entity node)
+ (encode-string "% "))
+ (encode-node (name node))
+ (encode-string " '")
+ (with-slots (children value) node
+ (cond (children
+ (mapc #'(lambda (byte) (funcall *writer-function *writer-arg
+ (code-char byte)))
+ children))
+ (value
+ (map nil #'encode-char value))))
+ (encode-string "' >"))
+
+(defMethod encode-node ((node def-external-entity))
+ (encode-string " <!ENTITY ")
+ (when (is-def-parameter-entity node)
+ (encode-string "% "))
+ (encode-node (name node))
+ (let ((system (system-id node))
+ (public (public-id node)))
+ (cond (public (encode-string " PUBLIC '")
+ (encode-node public)
+ (encode-string "' '")
+ (encode-node system)
+ (encode-node "'"))
+ (system (encode-string " SYSTEM '")
+ (encode-node system)
+ (encode-node "'"))))
+ (encode-string " >"))
+
+
+:EOF
Modified: branches/sbcl-0.9.x-testing/code/xparser/xml-stream-coding.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/xparser/xml-stream-coding.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/xparser/xml-stream-coding.lisp Tue Feb 14 11:52:41 2006
@@ -1 +1,732 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-
#|
<DOCUMENTATION>
<DESCRIPTION>
<P>
this implementes stream readers which perform decoding/encoding in the case
of a binary stream. the correct decoder is selected by first examining the type of
input element which the stream will offer and the, in the case of binary streams,
by examining the initial byte sequence.
no attempt is made to distinguish the encoder based on the stream's class.
the detection methods return a reader function together with its argument, the
detected decoding and, where it is necessary to read an initial byte sequence, that
sequence as a string to be reread.
</P>
</DESCRIPTION>
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
href='file://xml/sysdcl.lisp' />
<CHRONOLOGY>
<DELTA DATE='20010328' AUTHOR='JAA'>
adapted from version 0.4*</DELTA>
<DELTA DATE='20010605' AUTHOR='MS'>
LispWorks conformance</DELTA>
<DELTA DATE='20010621'>added a method to encode UTF-8 for character streams</DELTA>
<DELTA DATE='20010907'>
<ul><li><code>*xml-verbose*</code></li>
<li>fixed incorrect decoding for re-read sequence by recognized UTF-1612/21 BOM</li></ul></DELTA>
<DELTA DATE='20010914'>provisional us-ascii encoding method</DELTA>
<DELTA DATE='20020118'>corrections to encoding-stream-writer for non-mcl;
fixed autodetect code to recognize allegro :EOF; fixed us-ascii stream-reader for same.</DELTA>
<DELTA DATE='20030602'>provisioins for allegro simple-streams with character element-type</DELTA>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "XML-PARSER")
#+(or ALLEGRO LispWorks CormanLisp CMU sbcl)
(defMacro lsh (x y) `(ash ,x ,y))
#+(and allegro allegro-version>= (not (version>= 6 0)))
(progn
;; acl 5.0 versions
(defMethod stream-reader ((stream excl:fundamental-character-input-stream))
(let ((methods (compute-applicable-methods #'excl:stream-read-char (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'(lambda (arg)
(setf arg (excl:stream-read-char arg))
(unless (eq arg :eof) arg)))
stream)))
(defMethod stream-reader ((stream excl:fundamental-binary-input-stream))
(let ((methods (compute-applicable-methods #'excl:stream-read-byte (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'(lambda (arg)
(setf arg (excl:stream-read-byte arg))
(unless (eq arg :eof) arg)))
stream)))
(defMethod stream-writer ((stream excl:fundamental-character-output-stream))
(let ((methods (compute-applicable-methods #'excl:stream-write-char (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'excl:stream-write-char)
stream)))
(defMethod stream-writer ((stream excl:fundamental-binary-output-stream))
(let ((methods (compute-applicable-methods #'excl:stream-write-byte (list stream))))
(values (if (= (length methods) 1)
(clos:method-function (first methods))
#'excl:stream-write-byte)
stream)))
;; end acl5.0 versions
)
#+(and allegro allegro-version>= (version>= 6 0))
(progn
;; originally allegro 6.0 version
(defmethod stream-reader ((stream excl:fundamental-stream))
(values #'(lambda (stream) (read-byte stream nil nil))
stream))
(defmethod stream-writer ((stream excl:fundamental-stream))
(values #'(lambda (stream byte) (write-byte byte stream))
stream))
;; originally allegro 6.1 version; Bob Rogers <rogers(a)rgrjr.dyndns.org> remarked, that
;; they're present in 6.0 as well
(defmethod stream-reader ((stream excl:simple-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream) (read-char stream nil nil))
#'(lambda (stream) (read-byte stream nil nil)))
stream))
(defMethod stream-writer ((stream excl:simple-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char) (write-char char stream))
#'(lambda (stream byte) (write-byte byte stream)))
stream))
)
#+LispWorks
(defMethod stream-reader ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream) (read-char stream nil nil))
#'(lambda (stream) (read-byte stream nil nil)))
stream))
#+LispWorks
(defMethod stream-writer ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char) (write-char char stream))
#'(lambda (stream byte) (write-byte byte stream)))
stream))
#+CormanLisp
(defMethod stream-reader ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+CormanLisp
(defMethod stream-writer ((stream stream:fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
#+(and mcl (not digitool))
(defMethod stream-reader ((stream fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+(and mcl (not digitool))
(defMethod stream-writer ((stream fundamental-stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
#+CMU
(defmethod stream-element-type ((stream stream))
; (cl::fd-stream-element-type stream)
'(unsigned-byte 8))
#+CMU
(defMethod stream-reader ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+CMU
(defMethod stream-writer ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
#+sbcl
(defmethod stream-element-type ((stream stream))
; (cl::fd-stream-element-type stream)
'(unsigned-byte 8))
#+sbcl
(defMethod stream-reader ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream)
(read-char stream nil nil))
#'(lambda (stream)
(read-byte stream nil nil)))
stream))
#+sbcl
(defMethod stream-writer ((stream stream))
(values (if (subtypep (stream-element-type stream) 'character)
#'(lambda (stream char)
(write-char char stream))
#'(lambda (stream byte)
(write-byte byte stream)))
stream))
;; adapted from cl-http:mcl;server;tcp-ot-stream for the strictly binary case
;; the first case comes into play without cl-http. connections are made with a simple tcp stream
;; the second case takes into account, that chunking decoding extends the generic function
#+(and mcl mactcp-compatibility)
(defMethod stream-reader ((stream ccl::binary-tcp-stream))
(values #'ccl::io-buffer-read-byte (ccl::stream-io-buffer stream)))
#+(and MCL CL-HTTP)
(defmethod stream-reader ((stream ccl::modal-ascii-or-binary-tcp-stream-mixin))
(values (case (ccl::input-mode stream)
(:ascii #'stream-tyi)
((:binary nil)
(let ((method-combination (ccl::generic-function-method-combination #'ccl::stream-read-byte))
(methods (compute-applicable-methods #'ccl::stream-read-byte (list stream))))
(ccl::compute-effective-method-function #'ccl::stream-read-byte
method-combination
methods))))
stream))
#+(and mcl mactcp-compatibility)
(defmethod stream-writer ((stream ccl::binary-tcp-stream))
(flet ((io-buffer-tyo-byte (io-buffer byte)
;; ? not sure that continuability is a good idea, but
(unless (typep io-buffer 'ccl::io-buffer)
(setq io-buffer (require-type io-buffer 'ccl::io-buffer)))
(if (characterp byte) (setf byte (char-code byte)))
(ccl::%io-buffer-write-byte io-buffer byte)))
(values #'io-buffer-tyo-byte (ccl::stream-io-buffer stream))))
#+(and mcl mactcp-compatibility)
(defMethod stream-element-type ((stream ccl::binary-tcp-stream))
;; mcl 4.2 yielded BASE-CHARACTER for this class and produced a character reader ...?
'unsigned-byte)
;; determine whether the stream supports binary operations
(defGeneric is-binary-stream (stream)
#-allegro
(:method ((stream stream)) (subtypep (stream-element-type stream) 'unsigned-byte))
;; allegro 6 "simple streams" can always do the byte operations
#+allegro
(:method ((stream string-stream)) nil)
#+allegro
(:method ((stream stream))
#+(and allegro-version>= (version>= 6 0)) t
#+(and allegro-version>= (not (version>= 6 0))) (subtypep (stream-element-type stream) 'unsigned-byte)
))
(defGeneric decoding-stream-reader (stream encoding)
(:method ((stream stream) (encoding null))
(decoding-stream-reader stream (stream-element-type stream)))
(:method ((stream stream) (type cons))
(decoding-stream-reader stream (first type)))
(:method ((stream stream) (encoding string) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(decoding-stream-reader stream canonical-encoding))
(t
(warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding))))
(:method ((stream stream) (encoding symbol) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(decoding-stream-reader stream canonical-encoding))
((subtypep encoding 'integer)
(decoding-stream-reader stream :autodetect))
((subtypep encoding 'character)
(decoding-stream-reader stream *default-character-encoding*))
(t
(warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding)))))
(defGeneric encoding-stream-writer (stream encoding)
(:method ((stream t) (encoding t))
(warn "no decoding defined for operation on stream: ~s: ~s." encoding stream)
(values nil nil))
(:method ((stream stream) (encoding null) &aux (type (stream-element-type stream)))
(unless type
(warn "assuming element type character for stream: ~s." stream)
(setf type 'character))
(encoding-stream-writer stream type))
(:method ((stream stream) (type cons))
(encoding-stream-writer stream (first type)))
(:method ((stream stream) (encoding string) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(encoding-stream-writer stream canonical-encoding))
(t
(warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding))))
(:method ((stream stream) (encoding symbol) &aux canonical-encoding)
(cond ((setf canonical-encoding (canonical-encoding encoding))
(when *xml-verbose*
(warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
(encoding-stream-writer stream canonical-encoding))
((subtypep encoding 'integer)
(encoding-stream-writer stream *default-binary-encoding*))
((subtypep encoding 'character)
(encoding-stream-writer stream *default-character-encoding*))
(t
(warn "no encoding defined for operation on stream: ~s: ~s." stream encoding)
(values nil nil encoding)))))
(defMacro funcall-function.arg (function.arg &rest args)
`(funcall (first ,function.arg) (rest ,function.arg) ,@args))
(defun change-stream-decoding (new-encoding)
(etypecase new-encoding
(keyword t)
((or string (and symbol (not null)))
(setf new-encoding (intern (string-upcase new-encoding) "KEYWORD"))))
(if (or (eq new-encoding *input-encoding*)
(and (eq new-encoding :utf-16)
(member *input-encoding* '(:utf-16-12 :utf-16-21))))
(values *input-encoding* nil)
(multiple-value-bind (function arg detected-encoding to-reread)
(decoding-stream-reader *input-source* new-encoding)
(unless (and (eq detected-encoding new-encoding)
(null to-reread))
(error "can't change encoding: ~s: ~s -> ~s = ~s/~s."
*input-source*
*input-encoding* new-encoding detected-encoding to-reread))
(unless function (error "no reader for encoding: ~s." new-encoding))
(setf *input-reader* function
*input-reader-arg* arg
*input-encoding* new-encoding)
;; return the new encoding
(values new-encoding t))))
;;
;;
;; UTF-8 is computed
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-8)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-reader stream)
(values #'(lambda (function.arg &aux byte1)
(block read-utf-8-datum
(flet ((read-byte-code (&aux byte)
(setf byte (funcall-function.arg function.arg))
(if (integerp byte) byte
(return-from read-utf-8-datum nil))))
(declare (type fixnum byte1)
(ftype (function () fixnum) read-byte-code)
(optimize (speed 3) (safety 0)))
(setf byte1 (read-byte-code))
(cond ((= 0 (logand #x80 byte1))
byte1)
((= #xc0 (logand #xe0 byte1))
(logior (lsh (logand byte1 #x1f) 6)
(logand (read-byte-code) #x3f)))
((= #xe0 (logand #xf0 byte1))
(logior (logior (lsh (logand byte1 #x0f) 12)
(lsh (logand (read-byte-code) #x3f) 6))
(logand (read-byte-code) #x3f)))
((= #xf0 (logand #xf8 byte1))
(let ((byte2 (read-byte-code))
(byte3 (read-byte-code))
(byte4 (read-byte-code)))
(xml-error "unsupported unicode datum: ~s."
(list byte1 byte2 byte3 byte4))))
(t
(xml-error "illegal UTF-8 data: x~2,'0x." byte1))))))
(cons function arg)
:UTF-8)))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-8)))
(if (is-binary-stream stream)
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg char &aux (code (char-code char)))
(cond ((<= code 255)
(funcall-function.arg function.arg code))
((<= code #x03ff)
(funcall-function.arg function.arg (logior #b11000000 (lsh code -6)))
(funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
((<= code #xffff)
(funcall-function.arg function.arg (logior #b11100000 (lsh code -12)))
(funcall-function.arg function.arg (logior #b10000000 (logand (lsh code -6) #b00111111)))
(funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
(t
(xml-error "unsupported unicode datum: ~s." code))))
(cons function arg)))
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg char &aux (code (char-code char)))
(cond ((<= code 255)
(funcall-function.arg function.arg char))
(t
(let ((string (format nil "&#~d" code)))
(dotimes (x (length string))
(funcall-function.arg function.arg (char string x)))))))
(cons function arg)))))
;;
;;
;; ISO-8859-1 is direct
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :ISO-8859-1)))
(multiple-value-bind (function arg)
(stream-reader stream)
(if (is-binary-stream stream)
#-(or MCL LispWorks)
(multiple-value-bind (reader arg)
(stream-reader stream)
(values #'(lambda (function.arg &aux byte)
(setf byte (funcall-function.arg function.arg))
(when (integerp byte) byte))
(cons reader arg)
encoding))
#+(or MCL LispWorks)
(values function arg encoding)
;; character streams must be mapped back to binary
(values #'(lambda (function.arg &aux char)
(setf char (funcall-function.arg function.arg))
(when (characterp char)
;; hardcore tracing
;; (write-char char *trace-output*)
(char-code char)))
(cons function arg)
encoding))))
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :US-ASCII)))
(multiple-value-bind (function arg)
(stream-reader stream)
(if (is-binary-stream stream)
#-(or MCL LispWorks)
(multiple-value-bind (reader arg)
(stream-reader stream)
(values #'(lambda (function.arg &aux byte)
(setf byte (funcall-function.arg function.arg))
(when (integerp byte) byte))
(cons reader arg)
encoding))
#+(or MCL LispWorks)
(values function arg encoding)
;; character streams must be mapped back to binary
(values #'(lambda (function.arg &aux char)
(setf char (funcall-function.arg function.arg))
(when (characterp char)
(char-code char)))
(cons function arg)
encoding))))
#+digitool ;; fix eol
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :ISO-8859-1)))
(multiple-value-bind (function arg)
(stream-writer stream)
(if (is-binary-stream stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#x0d
(char-code char))))
(cons function arg)
encoding)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#.(code-char #x0d)
char)))
(cons function arg)
encoding))))
#-digitool
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :ISO-8859-1)))
(if (is-binary-stream stream)
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg (char-code char)))
(cons function arg)
encoding))
(multiple-value-bind (function arg)
(stream-writer stream)
(values function arg encoding))))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :US-ASCII)))
(multiple-value-bind (function arg)
(stream-writer stream)
#+digitool
(if (is-binary-stream stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#x0d
(char-code char))))
(cons function arg)
encoding)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg
(if (= (char-code char) #x0a)
#.(code-char #x0d)
char)))
(cons function arg)
encoding))
#-digitool
(if (is-binary-stream stream)
(values #'(lambda (function.arg char)
(funcall-function.arg function.arg (char-code char)))
(cons function arg)
encoding)
(values function arg encoding))))
;;
;;
;; UTF-16 distinguishes encoding order:
;; UTF-16LE is UTF16 in "little-endian" byte order. (order mark is 0xFF 0xFE)
;; UTF-16BE is UTF16 in "big-endian" byte order. (order mark is 0xFE 0xFF)
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-16)))
(decoding-stream-reader stream *default-utf-16-encoding*))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-16)))
(encoding-stream-writer stream *default-utf-16-encoding*))
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-16-12)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-reader stream)
(values #'(lambda (function.arg)
(declare (ftype (function () fixnum) read-byte-code)
(optimize (speed 3) (safety 0)))
(block read-utf-16-datum
(flet ((read-byte-code (&aux byte)
(setf byte (funcall-function.arg function.arg))
(if (integerp byte) byte
(return-from read-utf-16-datum nil))))
(+ (lsh (read-byte-code) 8) (read-byte-code)))))
(cons function arg)
encoding)))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-16-12)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg datum)
(setf datum (char-code datum))
(funcall-function.arg function.arg (logand #xff (lsh datum -8)))
(funcall-function.arg function.arg (logand #xff datum)))
(cons function arg))))
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :UTF-16-21)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-reader stream)
(values #'(lambda (function.arg)
(declare (ftype (function () fixnum) read-byte-code)
(optimize (speed 3) (safety 0)))
(block read-utf-16-datum
(flet ((read-byte-code (&aux byte)
(setf byte (funcall-function.arg function.arg))
(if (integerp byte) byte
(return-from read-utf-16-datum nil))))
(+ (read-byte-code) (lsh (read-byte-code) 8)))))
(cons function arg)
encoding)))
(defMethod encoding-stream-writer
((stream stream) (encoding (eql :UTF-16-21)))
(unless (is-binary-stream stream)
(warn "stream type not compatible with encoding: ~s: ~s."
(stream-element-type stream) encoding))
(multiple-value-bind (function arg)
(stream-writer stream)
(values #'(lambda (function.arg datum)
(setf datum (char-code datum))
(funcall-function.arg function.arg (logand #xff datum))
(funcall-function.arg function.arg (logand #xff (lsh datum -8))))
(cons function arg))))
;;
;;
;; detect encoding by reading the initial content. works for binary streams only
(defMethod decoding-stream-reader
((stream stream) (encoding (eql :autodetect)) &aux byte0 byte1 to-reread)
"see PR-xml Appendix F"
(multiple-value-bind (reader arg) (stream-reader stream)
(flet ((next-byte (&aux (byte (funcall reader arg)))
(typecase byte
(fixnum byte)
(t nil))))
(case (setf byte0 (next-byte))
(#x00 (case (next-byte)
(#x00 (case (next-byte)
(#x3c (if (= (next-byte) #x00)
(setf encoding :UCS-4-2143 to-reread "<")
(error "markup stream corrupt: ~s." stream)))
(#x00 (if (= (next-byte) #x3c)
(setf encoding :UCS-4-1234 to-reread "<")
(error "markup stream corrupt: ~s." stream)))
(#xFE (if (= (next-byte) #xFF)
(setf encoding :UCS-4-1234 to-reread nil)
(error "markup stream corrupt: ~s." stream)))
(#xFF (if (= (next-byte) #xFE)
(setf encoding :UCS-4-2143 to-reread nil)
(error "markup stream corrupt: ~s." stream)))
(t (error "markup stream corrupt: ~s." stream))))
(#x3c (if (= (setf byte1 (next-byte)) #x00)
(case (setf byte1 (next-byte))
(#x00 (setf encoding :UCS-4-3412 to-reread "<"))
(#x3f
(when *xml-verbose*
(warn "assuming UTF-16-21 encoding for stream: ~s." stream))
(setf encoding :UTF-16-21 to-reread "<?"))
(t (|EC: Byte Order Mark| :data (list #x00 #x3c #x00 byte1))))
(|EC: Byte Order Mark| :data (list #x00 #x3c byte1))))
(t
(error "markup stream corrupt: ~s." stream))))
(#x3c (case (setf byte1 (next-byte))
(#x00 (case (setf byte1 (next-byte))
(#x3f (case (setf byte1 (next-byte))
(#x00
(when *xml-verbose*
(warn "assuming UTF-16-12 encoding for stream: ~s." stream))
(setf encoding :UTF-16-12 to-reread "<?"))
(t
(|EC: Byte Order Mark| :data (list #x3c #x00 #x3f byte1)))))
(#x00 (if (= (next-byte) #x00)
(setf encoding :UCS-4-4321 to-reread "<")
(|EC: Byte Order Mark| :data (list #x3c #x00 #x00 byte1))))
(t
(|EC: Byte Order Mark| :data (list #x3c #x00 byte1)))))
(#x3f (setf encoding *default-binary-encoding* to-reread "<?"))
(t
(unless (or (xml-initial-namechar? byte1) (= byte1 #.(char-code #\!)))
(when *xml-verbose*
(warn "assuming UTF-8 encoding for stream: ~s." stream)))
(setf encoding *default-binary-encoding* to-reread (list byte0 byte1)))))
(#xEF (case (setf byte1 (next-byte))
(#xBB (if (= (setf byte1 (next-byte)) #xBF)
(setf encoding :UTF-8 to-reread nil)
(|EC: Byte Order Mark| :data (list #xEF #xBB byte1))))
(t
(|EC: Byte Order Mark| :data (list #xEF byte1)))))
(#xff
(if (= (setf byte1 (next-byte)) #xfe)
(let ((byte2 (next-byte)) (byte3 (next-byte)))
(if (and (= byte2 0) (= byte3 0))
(setf encoding :UCS4-4321 to-reread nil)
(setf encoding :UTF-16-21 to-reread (list (+ byte2 (lsh byte3 8))))))
(|EC: Byte Order Mark| :data (list #xff byte1))))
(#xfe
(if (= (setf byte1 (next-byte)) #xff)
(let ((byte2 (next-byte)) (byte3 (next-byte)))
(if (and (= byte2 0) (= byte3 0))
(setf encoding :UCS4-3412 to-reread nil)
(setf encoding :UTF-16-12 to-reread (list (+ (lsh byte2 8) byte3)))))
(|EC: Byte Order Mark| :data (list #xfe byte1))))
((nil) ;; no data in stream
(setf encoding :UTF-8 to-reread nil))
(t
(when *xml-verbose*
(warn "assuming UTF-8 encoding for stream: ~s." stream))
(setf encoding :UTF-8 to-reread (list byte0))))
(multiple-value-bind (reader arg encoding) (decoding-stream-reader stream encoding)
(values reader arg encoding to-reread)))))
#|
(defun utf-8-decoding (byte1 &optional (byte2 0) (byte3 0) (byte4 0))
(cond ((= 0 (logand #x80 byte1))
byte1)
((= #xc0 (logand #xe0 byte1))
(logior (lsh (logand byte1 #x1f) 6) (logand byte2 #x3f)))
((= #xe0 (logand #xf0 byte1))
(logior (logior (lsh (logand byte1 #x0f) 12) (lsh (logand byte2 #x3f) 6)) (logand byte3 #x3f)))
((= #xf0 (logand #xf8 byte1))
(xml-error "unsupported unicode datum: ~s."
(list byte1 byte2 byte3 byte4)))
(t
(xml-error "illegal UTF-8 data: #x~2,'0x." byte1))))
(xml-namechar? (utf-8-decoding 194 183 0 0))
(xml-space? (utf-8-decoding 239 187 191))
(apply #'utf-8-decoding (map 'list #'char-code "༤"))
(defun utf-8-decodingXstring (string)
(handler-case
(apply #'utf-8-decoding (map 'list #'char-code string))
(error (condition) (format nil "~s(~{~2,'0x~}) -> ~a"
string (map 'list #'char-code string)
condition))))
(format nil "~{~8,'0x~^~%~}" (mapcar #'utf-8-decodingXstring
'("" "氏" "" "�" "�")))
from the 3.1 unicode report
Table 3.1.
UTF-8 Bit Distribution
Scalar Value UTF-16 1st Byte 2nd Byte 3rd Byte 4th Byte
00000000 0xxxxxxx 00000000 0xxxxxxx 0xxxxxxx
00000yyy yyxxxxxx 00000yyy yyxxxxxx 110yyyyy 10xxxxxx
zzzzyyyy yyxxxxxx zzzzyyyy yyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx
000uuuuu zzzzyyyy 110110ww wwzzzzyy 11110uuu 10uuzzzz 10yyyyyy 10xxxxxx
yyxxxxxx 110111yy yyxxxxxx
Where uuuuu = wwww + 1 (to account for addition of 1000016 as in Section 3.7, Surrogates).
|#
:EOF
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-
+
+
+#|
+<DOCUMENTATION>
+ <DESCRIPTION>
+ <P>
+ this implementes stream readers which perform decoding/encoding in the case
+ of a binary stream. the correct decoder is selected by first examining the type of
+ input element which the stream will offer and the, in the case of binary streams,
+ by examining the initial byte sequence.
+ no attempt is made to distinguish the encoder based on the stream's class.
+ the detection methods return a reader function together with its argument, the
+ detected decoding and, where it is necessary to read an initial byte sequence, that
+ sequence as a string to be reread.
+ </P>
+ </DESCRIPTION>
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+ href='file://xml/sysdcl.lisp' />
+ <CHRONOLOGY>
+ <DELTA DATE='20010328' AUTHOR='JAA'>
+ adapted from version 0.4*</DELTA>
+ <DELTA DATE='20010605' AUTHOR='MS'>
+ LispWorks conformance</DELTA>
+ <DELTA DATE='20010621'>added a method to encode UTF-8 for character streams</DELTA>
+ <DELTA DATE='20010907'>
+ <ul><li><code>*xml-verbose*</code></li>
+ <li>fixed incorrect decoding for re-read sequence by recognized UTF-1612/21 BOM</li></ul></DELTA>
+ <DELTA DATE='20010914'>provisional us-ascii encoding method</DELTA>
+ <DELTA DATE='20020118'>corrections to encoding-stream-writer for non-mcl;
+ fixed autodetect code to recognize allegro :EOF; fixed us-ascii stream-reader for same.</DELTA>
+ </CHRONOLOGY>
+ </DOCUMENTATION>
+|#
+
+(in-package "XML-PARSER")
+
+#+(or ALLEGRO LispWorks CormanLisp CMU sbcl)
+(defMacro lsh (x y) `(ash ,x ,y))
+
+#+(and allegro allegro-version>= (not (version>= 6 0)))
+(progn
+ ;; acl 5.0 versions
+
+ (defMethod stream-reader ((stream excl:fundamental-character-input-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-read-char (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'(lambda (arg)
+ (setf arg (excl:stream-read-char arg))
+ (unless (eq arg :eof) arg)))
+ stream)))
+
+ (defMethod stream-reader ((stream excl:fundamental-binary-input-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-read-byte (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'(lambda (arg)
+ (setf arg (excl:stream-read-byte arg))
+ (unless (eq arg :eof) arg)))
+ stream)))
+
+ (defMethod stream-writer ((stream excl:fundamental-character-output-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-write-char (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'excl:stream-write-char)
+ stream)))
+
+ (defMethod stream-writer ((stream excl:fundamental-binary-output-stream))
+ (let ((methods (compute-applicable-methods #'excl:stream-write-byte (list stream))))
+ (values (if (= (length methods) 1)
+ (clos:method-function (first methods))
+ #'excl:stream-write-byte)
+ stream)))
+ ;; end acl5.0 versions
+ )
+
+#+(and allegro allegro-version>= (version>= 6 0))
+(progn
+ ;; originally allegro 6.0 version
+ (defmethod stream-reader ((stream excl:fundamental-stream))
+ (values #'(lambda (stream) (read-byte stream nil nil))
+ stream))
+ (defmethod stream-writer ((stream excl:fundamental-stream))
+ (values #'(lambda (stream byte) (write-byte byte stream))
+ stream))
+
+
+ ;; originally allegro 6.1 version; Bob Rogers <rogers(a)rgrjr.dyndns.org> remarked, that
+ ;; they're present in 6.0 as well
+ (defmethod stream-reader ((stream excl:simple-stream))
+ (values #'(lambda (stream) (read-byte stream nil nil))
+ stream))
+ (defmethod stream-writer ((stream excl:simple-stream))
+ (values #'(lambda (stream byte) (write-byte byte stream))
+ stream))
+ )
+
+#+LispWorks
+(defMethod stream-reader ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream) (read-char stream nil nil))
+ #'(lambda (stream) (read-byte stream nil nil)))
+ stream))
+#+LispWorks
+(defMethod stream-writer ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+CormanLisp
+(defMethod stream-reader ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+CormanLisp
+(defMethod stream-writer ((stream stream:fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+(and mcl (not digitool))
+(defMethod stream-reader ((stream fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+
+#+(and mcl (not digitool))
+(defMethod stream-writer ((stream fundamental-stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+CMU
+(defmethod stream-element-type ((stream stream))
+ ; (cl::fd-stream-element-type stream)
+ '(unsigned-byte 8))
+
+#+CMU
+(defMethod stream-reader ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+CMU
+(defMethod stream-writer ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+#+sbcl
+(defmethod stream-element-type ((stream stream))
+ ; (cl::fd-stream-element-type stream)
+ '(unsigned-byte 8))
+
+#+sbcl
+(defMethod stream-reader ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream)
+ (read-char stream nil nil))
+ #'(lambda (stream)
+ (read-byte stream nil nil)))
+ stream))
+#+sbcl
+(defMethod stream-writer ((stream stream))
+ (values (if (subtypep (stream-element-type stream) 'character)
+ #'(lambda (stream char)
+ (write-char char stream))
+ #'(lambda (stream byte)
+ (write-byte byte stream)))
+ stream))
+
+
+
+;; adapted from cl-http:mcl;server;tcp-ot-stream for the strictly binary case
+;; the first case comes into play without cl-http. connections are made with a simple tcp stream
+;; the second case takes into account, that chunking decoding extends the generic function
+#+(and mcl mactcp-compatibility)
+(defMethod stream-reader ((stream ccl::binary-tcp-stream))
+ (values #'ccl::io-buffer-read-byte (ccl::stream-io-buffer stream)))
+
+#+(and MCL CL-HTTP)
+(defmethod stream-reader ((stream ccl::modal-ascii-or-binary-tcp-stream-mixin))
+ (values (case (ccl::input-mode stream)
+ (:ascii #'stream-tyi)
+ ((:binary nil)
+ (let ((method-combination (ccl::generic-function-method-combination #'ccl::stream-read-byte))
+ (methods (compute-applicable-methods #'ccl::stream-read-byte (list stream))))
+ (ccl::compute-effective-method-function #'ccl::stream-read-byte
+ method-combination
+ methods))))
+ stream))
+
+#+(and mcl mactcp-compatibility)
+(defmethod stream-writer ((stream ccl::binary-tcp-stream))
+ (flet ((io-buffer-tyo-byte (io-buffer byte)
+ ;; ? not sure that continuability is a good idea, but
+ (unless (typep io-buffer 'ccl::io-buffer)
+ (setq io-buffer (require-type io-buffer 'ccl::io-buffer)))
+ (if (characterp byte) (setf byte (char-code byte)))
+ (ccl::%io-buffer-write-byte io-buffer byte)))
+ (values #'io-buffer-tyo-byte (ccl::stream-io-buffer stream))))
+
+
+#+(and mcl mactcp-compatibility)
+(defMethod stream-element-type ((stream ccl::binary-tcp-stream))
+ ;; mcl 4.2 yielded BASE-CHARACTER for this class and produced a character reader ...?
+ 'unsigned-byte)
+
+;; determine whether the stream supports binary operations
+
+(defGeneric is-binary-stream (stream)
+ #-allegro
+ (:method ((stream stream)) (subtypep (stream-element-type stream) 'unsigned-byte))
+ ;; allegro 6 "simple streams" can always do the byte operations
+ #+allegro
+ (:method ((stream stream))
+ #+(and allegro-version>= (version>= 6 0)) t
+ #+(and allegro-version>= (not (version>= 6 0))) (subtypep (stream-element-type stream) 'unsigned-byte)
+ ))
+
+(defGeneric decoding-stream-reader (stream encoding)
+ (:method ((stream stream) (encoding null))
+ (decoding-stream-reader stream (stream-element-type stream)))
+ (:method ((stream stream) (type cons))
+ (decoding-stream-reader stream (first type)))
+ (:method ((stream stream) (encoding string) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (decoding-stream-reader stream canonical-encoding))
+ (t
+ (warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding))))
+ (:method ((stream stream) (encoding symbol) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (decoding-stream-reader stream canonical-encoding))
+ ((subtypep encoding 'integer)
+ (decoding-stream-reader stream :autodetect))
+ ((subtypep encoding 'character)
+ (decoding-stream-reader stream *default-character-encoding*))
+ (t
+ (warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding)))))
+
+(defGeneric encoding-stream-writer (stream encoding)
+ (:method ((stream t) (encoding t))
+ (warn "no decoding defined for operation on stream: ~s: ~s." encoding stream)
+ (values nil nil))
+ (:method ((stream stream) (encoding null) &aux (type (stream-element-type stream)))
+ (unless type
+ (warn "assuming element type character for stream: ~s." stream)
+ (setf type 'character))
+ (encoding-stream-writer stream type))
+ (:method ((stream stream) (type cons))
+ (encoding-stream-writer stream (first type)))
+ (:method ((stream stream) (encoding string) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (encoding-stream-writer stream canonical-encoding))
+ (t
+ (warn "no decoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding))))
+ (:method ((stream stream) (encoding symbol) &aux canonical-encoding)
+ (cond ((setf canonical-encoding (canonical-encoding encoding))
+ (when *xml-verbose*
+ (warn "assuming ~a encoding for stream: ~s." canonical-encoding stream))
+ (encoding-stream-writer stream canonical-encoding))
+ ((subtypep encoding 'integer)
+ (encoding-stream-writer stream *default-binary-encoding*))
+ ((subtypep encoding 'character)
+ (encoding-stream-writer stream *default-character-encoding*))
+ (t
+ (warn "no encoding defined for operation on stream: ~s: ~s." stream encoding)
+ (values nil nil encoding)))))
+
+
+(defMacro funcall-function.arg (function.arg &rest args)
+ `(funcall (first ,function.arg) (rest ,function.arg) ,@args))
+
+(defun change-stream-decoding (new-encoding)
+ (etypecase new-encoding
+ (keyword t)
+ ((or string (and symbol (not null)))
+ (setf new-encoding (intern (string-upcase new-encoding) "KEYWORD"))))
+ (if (or (eq new-encoding *input-encoding*)
+ (and (eq new-encoding :utf-16)
+ (member *input-encoding* '(:utf-16-12 :utf-16-21))))
+ (values *input-encoding* nil)
+ (multiple-value-bind (function arg detected-encoding to-reread)
+ (decoding-stream-reader *input-source* new-encoding)
+ (unless (and (eq detected-encoding new-encoding)
+ (null to-reread))
+ (error "can't change encoding: ~s: ~s -> ~s = ~s/~s."
+ *input-source*
+ *input-encoding* new-encoding detected-encoding to-reread))
+ (unless function (error "no reader for encoding: ~s." new-encoding))
+ (setf *input-reader* function
+ *input-reader-arg* arg
+ *input-encoding* new-encoding)
+ ;; return the new encoding
+ (values new-encoding t))))
+
+;;
+;;
+;; UTF-8 is computed
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-8)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg &aux byte1)
+ (block read-utf-8-datum
+ (flet ((read-byte-code (&aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (if (integerp byte) byte
+ (return-from read-utf-8-datum nil))))
+ (declare (type fixnum byte1)
+ (ftype (function () fixnum) read-byte-code)
+ (optimize (speed 3) (safety 0)))
+ (setf byte1 (read-byte-code))
+ (cond ((= 0 (logand #x80 byte1))
+ byte1)
+ ((= #xc0 (logand #xe0 byte1))
+ (logior (lsh (logand byte1 #x1f) 6)
+ (logand (read-byte-code) #x3f)))
+ ((= #xe0 (logand #xf0 byte1))
+ (logior (logior (lsh (logand byte1 #x0f) 12)
+ (lsh (logand (read-byte-code) #x3f) 6))
+ (logand (read-byte-code) #x3f)))
+ ((= #xf0 (logand #xf8 byte1))
+ (let ((byte2 (read-byte-code))
+ (byte3 (read-byte-code))
+ (byte4 (read-byte-code)))
+ (xml-error "unsupported unicode datum: ~s."
+ (list byte1 byte2 byte3 byte4))))
+ (t
+ (xml-error "illegal UTF-8 data: x~2,'0x." byte1))))))
+ (cons function arg)
+ :UTF-8)))
+
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-8)))
+ (if (is-binary-stream stream)
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg char &aux (code (char-code char)))
+ (cond ((<= code 255)
+ (funcall-function.arg function.arg code))
+ ((<= code #x03ff)
+ (funcall-function.arg function.arg (logior #b11000000 (lsh code -6)))
+ (funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
+ ((<= code #xffff)
+ (funcall-function.arg function.arg (logior #b11100000 (lsh code -12)))
+ (funcall-function.arg function.arg (logior #b10000000 (logand (lsh code -6) #b00111111)))
+ (funcall-function.arg function.arg (logior #b10000000 (logand code #b00111111))))
+ (t
+ (xml-error "unsupported unicode datum: ~s." code))))
+ (cons function arg)))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg char &aux (code (char-code char)))
+ (cond ((<= code 255)
+ (funcall-function.arg function.arg char))
+ (t
+ (let ((string (format nil "&#~d" code)))
+ (dotimes (x (length string))
+ (funcall-function.arg function.arg (char string x)))))))
+ (cons function arg)))))
+
+;;
+;;
+;; ISO-8859-1 is direct
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :ISO-8859-1)))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (if (is-binary-stream stream)
+ #-(or MCL LispWorks)
+ (multiple-value-bind (reader arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg &aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (when (integerp byte) byte))
+ (cons reader arg)
+ encoding))
+ #+(or MCL LispWorks)
+ (values function arg encoding)
+ ;; character streams must be mapped back to binary
+ (values #'(lambda (function.arg &aux char)
+ (setf char (funcall-function.arg function.arg))
+ (when (characterp char)
+ ;; hardcore tracing
+ ;; (write-char char *trace-output*)
+ (char-code char)))
+ (cons function arg)
+ encoding))))
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :US-ASCII)))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (if (is-binary-stream stream)
+ #-(or MCL LispWorks)
+ (multiple-value-bind (reader arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg &aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (when (integerp byte) byte))
+ (cons reader arg)
+ encoding))
+ #+(or MCL LispWorks)
+ (values function arg encoding)
+ ;; character streams must be mapped back to binary
+ (values #'(lambda (function.arg &aux char)
+ (setf char (funcall-function.arg function.arg))
+ (when (characterp char)
+ (char-code char)))
+ (cons function arg)
+ encoding))))
+
+#+digitool ;; fix eol
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :ISO-8859-1)))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (if (is-binary-stream stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #x0d
+ (char-code char))))
+ (cons function arg)
+ encoding)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #.(code-char #x0d)
+ char)))
+ (cons function arg)
+ encoding))))
+
+#-digitool
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :ISO-8859-1)))
+ (if (is-binary-stream stream)
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg (char-code char)))
+ (cons function arg)
+ encoding))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values function arg encoding))))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :US-ASCII)))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ #+digitool
+ (if (is-binary-stream stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #x0d
+ (char-code char))))
+ (cons function arg)
+ encoding)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg
+ (if (= (char-code char) #x0a)
+ #.(code-char #x0d)
+ char)))
+ (cons function arg)
+ encoding))
+ #-digitool
+ (if (is-binary-stream stream)
+ (values #'(lambda (function.arg char)
+ (funcall-function.arg function.arg (char-code char)))
+ (cons function arg)
+ encoding)
+ (values function arg encoding))))
+
+;;
+;;
+;; UTF-16 distinguishes encoding order:
+;; UTF-16LE is UTF16 in "little-endian" byte order. (order mark is 0xFF 0xFE)
+;; UTF-16BE is UTF16 in "big-endian" byte order. (order mark is 0xFE 0xFF)
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-16)))
+ (decoding-stream-reader stream *default-utf-16-encoding*))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-16)))
+ (encoding-stream-writer stream *default-utf-16-encoding*))
+
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-16-12)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg)
+ (declare (ftype (function () fixnum) read-byte-code)
+ (optimize (speed 3) (safety 0)))
+ (block read-utf-16-datum
+ (flet ((read-byte-code (&aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (if (integerp byte) byte
+ (return-from read-utf-16-datum nil))))
+ (+ (lsh (read-byte-code) 8) (read-byte-code)))))
+ (cons function arg)
+ encoding)))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-16-12)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg datum)
+ (setf datum (char-code datum))
+ (funcall-function.arg function.arg (logand #xff (lsh datum -8)))
+ (funcall-function.arg function.arg (logand #xff datum)))
+ (cons function arg))))
+
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :UTF-16-21)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-reader stream)
+ (values #'(lambda (function.arg)
+ (declare (ftype (function () fixnum) read-byte-code)
+ (optimize (speed 3) (safety 0)))
+ (block read-utf-16-datum
+ (flet ((read-byte-code (&aux byte)
+ (setf byte (funcall-function.arg function.arg))
+ (if (integerp byte) byte
+ (return-from read-utf-16-datum nil))))
+ (+ (read-byte-code) (lsh (read-byte-code) 8)))))
+ (cons function arg)
+ encoding)))
+
+(defMethod encoding-stream-writer
+ ((stream stream) (encoding (eql :UTF-16-21)))
+ (unless (is-binary-stream stream)
+ (warn "stream type not compatible with encoding: ~s: ~s."
+ (stream-element-type stream) encoding))
+ (multiple-value-bind (function arg)
+ (stream-writer stream)
+ (values #'(lambda (function.arg datum)
+ (setf datum (char-code datum))
+ (funcall-function.arg function.arg (logand #xff datum))
+ (funcall-function.arg function.arg (logand #xff (lsh datum -8))))
+ (cons function arg))))
+
+
+
+;;
+;;
+;; detect encoding by reading the initial content. works for binary streams only
+
+(defMethod decoding-stream-reader
+ ((stream stream) (encoding (eql :autodetect)) &aux byte0 byte1 to-reread)
+ "see PR-xml Appendix F"
+ (multiple-value-bind (reader arg) (stream-reader stream)
+ (flet ((next-byte (&aux (byte (funcall reader arg)))
+ (typecase byte
+ (fixnum byte)
+ (t nil))))
+ (case (setf byte0 (next-byte))
+ (#x00 (case (next-byte)
+ (#x00 (case (next-byte)
+ (#x3c (if (= (next-byte) #x00)
+ (setf encoding :UCS-4-2143 to-reread "<")
+ (error "markup stream corrupt: ~s." stream)))
+ (#x00 (if (= (next-byte) #x3c)
+ (setf encoding :UCS-4-1234 to-reread "<")
+ (error "markup stream corrupt: ~s." stream)))
+ (#xFE (if (= (next-byte) #xFF)
+ (setf encoding :UCS-4-1234 to-reread nil)
+ (error "markup stream corrupt: ~s." stream)))
+ (#xFF (if (= (next-byte) #xFE)
+ (setf encoding :UCS-4-2143 to-reread nil)
+ (error "markup stream corrupt: ~s." stream)))
+ (t (error "markup stream corrupt: ~s." stream))))
+ (#x3c (if (= (setf byte1 (next-byte)) #x00)
+ (case (setf byte1 (next-byte))
+ (#x00 (setf encoding :UCS-4-3412 to-reread "<"))
+ (#x3f
+ (when *xml-verbose*
+ (warn "assuming UTF-16-21 encoding for stream: ~s." stream))
+ (setf encoding :UTF-16-21 to-reread "<?"))
+ (t (|EC: Byte Order Mark| :data (list #x00 #x3c #x00 byte1))))
+ (|EC: Byte Order Mark| :data (list #x00 #x3c byte1))))
+ (t
+ (error "markup stream corrupt: ~s." stream))))
+ (#x3c (case (setf byte1 (next-byte))
+ (#x00 (case (setf byte1 (next-byte))
+ (#x3f (case (setf byte1 (next-byte))
+ (#x00
+ (when *xml-verbose*
+ (warn "assuming UTF-16-12 encoding for stream: ~s." stream))
+ (setf encoding :UTF-16-12 to-reread "<?"))
+ (t
+ (|EC: Byte Order Mark| :data (list #x3c #x00 #x3f byte1)))))
+ (#x00 (if (= (next-byte) #x00)
+ (setf encoding :UCS-4-4321 to-reread "<")
+ (|EC: Byte Order Mark| :data (list #x3c #x00 #x00 byte1))))
+ (t
+ (|EC: Byte Order Mark| :data (list #x3c #x00 byte1)))))
+ (#x3f (setf encoding *default-binary-encoding* to-reread "<?"))
+ (t
+ (unless (or (xml-initial-namechar? byte1) (= byte1 #.(char-code #\!)))
+ (when *xml-verbose*
+ (warn "assuming UTF-8 encoding for stream: ~s." stream)))
+ (setf encoding *default-binary-encoding* to-reread (list byte0 byte1)))))
+ (#xEF (case (setf byte1 (next-byte))
+ (#xBB (if (= (setf byte1 (next-byte)) #xBF)
+ (setf encoding :UTF-8 to-reread nil)
+ (|EC: Byte Order Mark| :data (list #xEF #xBB byte1))))
+ (t
+ (|EC: Byte Order Mark| :data (list #xEF byte1)))))
+ (#xff
+ (if (= (setf byte1 (next-byte)) #xfe)
+ (let ((byte2 (next-byte)) (byte3 (next-byte)))
+ (if (and (= byte2 0) (= byte3 0))
+ (setf encoding :UCS4-4321 to-reread nil)
+ (setf encoding :UTF-16-21 to-reread (list (+ byte2 (lsh byte3 8))))))
+ (|EC: Byte Order Mark| :data (list #xff byte1))))
+ (#xfe
+ (if (= (setf byte1 (next-byte)) #xff)
+ (let ((byte2 (next-byte)) (byte3 (next-byte)))
+ (if (and (= byte2 0) (= byte3 0))
+ (setf encoding :UCS4-3412 to-reread nil)
+ (setf encoding :UTF-16-12 to-reread (list (+ (lsh byte2 8) byte3)))))
+ (|EC: Byte Order Mark| :data (list #xfe byte1))))
+ ((nil) ;; no data in stream
+ (setf encoding :UTF-8 to-reread nil))
+ (t
+ (when *xml-verbose*
+ (warn "assuming UTF-8 encoding for stream: ~s." stream))
+ (setf encoding :UTF-8 to-reread (list byte0))))
+ (multiple-value-bind (reader arg encoding) (decoding-stream-reader stream encoding)
+ (values reader arg encoding to-reread)))))
+
+
+
+#|
+
+(defun utf-8-decoding (byte1 &optional (byte2 0) (byte3 0) (byte4 0))
+ (cond ((= 0 (logand #x80 byte1))
+ byte1)
+ ((= #xc0 (logand #xe0 byte1))
+ (logior (lsh (logand byte1 #x1f) 6) (logand byte2 #x3f)))
+ ((= #xe0 (logand #xf0 byte1))
+ (logior (logior (lsh (logand byte1 #x0f) 12) (lsh (logand byte2 #x3f) 6)) (logand byte3 #x3f)))
+ ((= #xf0 (logand #xf8 byte1))
+ (xml-error "unsupported unicode datum: ~s."
+ (list byte1 byte2 byte3 byte4)))
+ (t
+ (xml-error "illegal UTF-8 data: #x~2,'0x." byte1))))
+(xml-namechar? (utf-8-decoding 194 183 0 0))
+(xml-space? (utf-8-decoding 239 187 191))
+
+(apply #'utf-8-decoding (map 'list #'char-code "༤"))
+
+(defun utf-8-decodingXstring (string)
+ (handler-case
+ (apply #'utf-8-decoding (map 'list #'char-code string))
+ (error (condition) (format nil "~s(~{~2,'0x~}) -> ~a"
+ string (map 'list #'char-code string)
+ condition))))
+
+(format nil "~{~8,'0x~^~%~}" (mapcar #'utf-8-decodingXstring
+ '("" "氏" "" "�" "�")))
+
+from the 3.1 unicode report
+
+ Table 3.1.
+ UTF-8 Bit Distribution
+ Scalar Value UTF-16 1st Byte 2nd Byte 3rd Byte 4th Byte
+ 00000000 0xxxxxxx 00000000 0xxxxxxx 0xxxxxxx
+
+ 00000yyy yyxxxxxx 00000yyy yyxxxxxx 110yyyyy 10xxxxxx
+
+ zzzzyyyy yyxxxxxx zzzzyyyy yyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx
+
+ 000uuuuu zzzzyyyy 110110ww wwzzzzyy 11110uuu 10uuzzzz 10yyyyyy 10xxxxxx
+ yyxxxxxx 110111yy yyxxxxxx
+
+Where uuuuu = wwww + 1 (to account for addition of 1000016 as in Section 3.7, Surrogates).
+
+|#
+:EOF
Modified: branches/sbcl-0.9.x-testing/code/xquerydatamodel/xqdm-classes.lisp
==============================================================================
--- branches/sbcl-0.9.x-testing/code/xquerydatamodel/xqdm-classes.lisp (original)
+++ branches/sbcl-0.9.x-testing/code/xquerydatamodel/xqdm-classes.lisp Tue Feb 14 11:52:41 2006
@@ -1 +1,1788 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-query-data-model; -*-
#|
<DOCUMENTATION>
<DESCRIPTION>
these classes implement an XML query data model
(<a href='WD-query-datamod-20010215%20.html'>XQDM</a>) conformant XML document model.
the interface is consistent with the XML infoset
(<a href='WD-xml-infoset-20010202.html'>XMLI</a>).
this includes support for all node types and an
interface which adopt analogous accessor names.
<p>
where differences exist between the infoset and the query data model the implementation
follows XQDM, because the latter
<ul>
<li>includes the type information,</li>
<li>permits a wider range of attribute and element content, whereby
the parsing and serialization ensure that the xml standard's constraints
are upheld for serial forms.</li>
</ul>
</p><p>
the model varies from the standards in several respects:
<ul>
<li>the <code>NaR</code> distinguished value is represented with
<code>NIL</code>. the context of use is sufficient to distinguish
between an empty list and an absent atom.</li>
<li>the <code>StringValue</code> <code>valueNode</code> is modeled as a string.
as for the remaining types, a class is provided, but the parser produces strings.</li>
<li>numerous information items are retained as distinguished nodes
rather than masking them as opaque nodes. this includes entities and entity
references. the attribute and element node accessors conform to the spec in that they
combine content to produce the required value.
this makes it easier to represent the literal encoding in a single model.
the parser, on the other hand, always expands entity references.
</li>
<li>cdata and entity markers are not supported. the respective content is
instead encapsulated in a reified instance, either directly - as for cdata,
or indirectly - as for an entity reference.</li>
</ul>
</p>
</DESCRIPTION>
<COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
href='file://xml/sysdcl.lisp' />
<CHRONOLOGY>
<DELTA DATE='19990000' AUTHOR='JAA'>
this started as a minimal xml document model. to wit, from the original description:
<quote>
this is an absolutely minimal and nonconforming xml processor.
it reads the main document entity, skipping all processing
instructions, declarations, and definitions. it returns only the
single element in the document. it recognizes entities for <![CDATA[<>&]]>
and translates them on input and output. no other entites are
supported.
</quote></DELTA>
<DELTA DATE='19990209' AUTHOR='JAA'>
jaa added attribute support
</DELTA>
<DELTA DATE='20010223' AUTHOR='JAA'>
comments, processing instructions and reified attributes
</DELTA>
<DELTA DATE='20010226' AUTHOR='JAA'>
changed names to symbols to support namespaces
</DELTA><DELTA DATE='20010301' AUTHOR='JAA'>
interface and classes changed to align with the query data model
</DELTA>
<DELTA DATE='20010308' AUTHOR='JAA'>
incorporated accessors and accommodated properties from the infoset.
note that
<ul>
<li>no entity start or end nodes are modeled</li>
<li>the URI handling is incomplete.</li></ul></DELTA>
<DELTA DATE='20010412' AUTHOR='JAA'>
eliminated teh attribute slot from doc-node.</DELTA>
<DELTA DATE='20010501' AUTHOR='JAA'>
factored out xml-encoding specific classes.</DELTA>
<DELTA DATE='20010520'>clone/copy-node to accept overriding initargs</DELTA>
<DELTA DATE='20010530'>
REF-ENTITY needs to be a NAMED-NODE, in order to bind the target name</DELTA>
<DELTA DATE='20010604'>
model traversal moved her from xqdm-qnames</DELTA>
<DELTA DATE='20010605' AUTHOR='MS'>lispworks conformance</DELTA>
<DELTA DATE='20010611'> added |VC: No Duplicate Tokens|</DELTA>
<DELTA DATE='20010622'> reader adjustments on null symbol names</DELTA>
<DELTA DATE='20010625' AUTHOR='RLF'>fixed arguments in FIRST-MODEL-NAME</DELTA>
<DELTA DATE='20010625'>
adjustments to print-object for *-model for PCDATA
<br />
eliminated <code>VALUE</code> speciaization for <code>NS-NODE</code></DELTA>
<DELTA DATE='20010626'>eliminated <code>ABSTRACT-NODE</code> from <code>ORDINAL-NODE</code>
in order to reduce the implementation of <code>ABSTRACT-ELEM-NODE</code>, which thereby now
prescribes <code>ORDINAL</code> and <code>DOCUMENT</code> slots only.
changed <code>*CLASS.*</code> parameters to bind classes rather than names
</DELTA>
<DELTA DATE='20010703'>added attribute initargs to def-type-qname-context</DELTA>
<DELTA DATE='20010803'>added def-type.node-validator reader</DELTA>
<DELTA DATE='20010816'>additions for schema types</DELTA>
<DELTA DATE='20010906'>updated print-object methods for name instances</DELTA>
<DELTA DATE='20010914'>ns-nodes for xml and xmlns namespace bindings</DELTA>
<DELTA DATE='20011010'>duration-scoped-nodes</DELTA>
<DELTA DATE='20011230'>added value alternative to print-object for general entity defs</DELTA>
<DELTA DATE='20020116'>names for nameset-tokenizers now accessed with name method</DELTA>
<DELTA DATE='20020117'>correction to print-object (def-element-type)</DELTA>
<DELTA DATE"'20030320'>conditions consistent with 0.950</DELTA>
<DELTA DATE='20030805'>correction to type specified for name slot in named</DELTA>
</CHRONOLOGY>
</DOCUMENTATION>
|#
(in-package "XML-QUERY-DATA-MODEL")
;;
;;
;; classes
;; abstract
(eval-when (:compile-toplevel :load-toplevel :execute)
(defClass abstract-class (standard-class) ())
(defMethod validate-superclass
((class abstract-class) (superclass standard-class))
t)
(defMethod validate-superclass
((class standard-class) (superclass abstract-class))
t)
)
(defMethod make-instance ((class abstract-class) &key)
(xml-error "instantiation precluded for class: ~s." class))
(defClass abstract-node ()
((parent :initform nil :initarg :parent :accessor parent
:type (or abstract-node null))
(children :initarg :children :accessor children))
(:metaclass abstract-class)
(:documentation
"an <code>ABSTRACT-NODE</code> constitutes the generic form of all instances
in a document model and its definition. it comprises the one-many graph
relation intrinsic to the document model. it stipulates this structure for
all nodes. this even for nodes like <code>DOC-NODE</code> and
<code>ATTR-NODE</code>, which maintain a relation to a dominant node, even
though they do not have <em>parents</em> according to the DOM
specifications."))
(defClass abstract-value-node (abstract-node)
((value :initarg :value))
(:metaclass abstract-class)
(:documentation
"an <code>ABSTRACT-VALUE-NODE</code> encapsulates a datum in a node so that it can be
integrated into the document graph. a value which may well be modeled with
an atom (eg. a number or a string) still has children, to collect the
raw parsed form as its children and to permit complex representations for
serialization.
the specializations include both direct encapsulations and more complex, annotated values,
such as type and entity definitions, element properties, and entity information."))
(defClass named (abstract-node)
((name :initform *null-name* :initarg :name :accessor name
:type name))
(:metaclass abstract-class))
(defClass named-node (named) () (:metaclass abstract-class))
(defClass unamed (named) () (:metaclass abstract-class))
(defClass unamed-node (unamed named-node) () (:metaclass abstract-class))
(defClass ncnamed (named) () (:metaclass abstract-class))
(defClass ncnamed-node (ncnamed named-node) () (:metaclass abstract-class))
(defClass typed-node (abstract-node)
((def :initform nil :initarg :def :accessor def
:type (or null abstract-def-type)))
(:metaclass abstract-class)
(:documentation
"an abstract class which introduces a definition property for an instance."))
(defClass document-scoped-node ()
((document :initform nil :initarg :document :accessor document))
(:metaclass abstract-class)
(:documentation
"mixin form for classes which exist relative to a document.
nb. it makes no provisions for graph relations."))
(defClass duration-scoped-node ()
((ephemeral :initform nil :initarg :ephemeral
:reader is-ephemeral :writer (setf ephemeral)
:documentation
"ranges over T, NIL to specify whether to include the node when serializing."))
(:metaclass abstract-class)
(:documentation
"mixin class to record whether a node should be included in serialized documents.
in particular, generated namespaces are not serialized by default."))
(defClass ordinal-node ()
((ordinality :initform 0 :initarg :ordinality :type (or fixnum null) :accessor ordinality))
(:metaclass abstract-class)
(:documentation
"a mixin form which binds a position in a global order.
this is used to cache the original document order for elements and the local order
for references. nb. it makes no provisions for graph relations."))
(defClass document () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass doc-node-interface (document)
()
(:metaclass abstract-class)
(:documentation
"a mixin marker to indicate that the class implements the minimal document node interface
required for serialization:
(root children encoding entity-info general-entities notations parameter-entities standalone
types version)."))
(defClass elem-node-interface ()
()
(:metaclass abstract-class)
(:documentation
"a marker mixin to indicate that the class implements the minimal element node interface
required for serialization:
(name parent children attributes namespaces)."))
(defClass elem-property-node-interface ()
()
(:metaclass abstract-class)
(:documentation
"a marker mixin to indicate that the class implements the minimal element property interface
required for serialization:
(name children)."))
(defClass entity-information-node (ncnamed-node abstract-value-node)
((uri :initform nil :initarg :uri :accessor uri
:documentation
"for the document entity, this binds the explicit uri.
for external references, it binds the instance form of the system-id.
this is generated by resolving the system-id relative to the containing entity.
it could also be generated from th epublic id.")
(system-id :initform nil :initarg :system-id :accessor system-id)
(public-id :initform nil :initarg :public-id :accessor public-id)
(encoding :initform nil :initarg :encoding :initarg :encoding-decl
:reader encoding)
(version :initform nil :initarg :version :initarg :version-info
:accessor version)))
(defClass entity-delegate ()
((entity-info :initform nil :initarg :entity-info :writer (setf entity-info)
:type (or entity-information-node null)))
(:metaclass abstract-class)
(:documentation
"an abstract root for classes which implement references to external entities "))
(defClass attr-child-node ()
()
(:metaclass abstract-class)
(:documentation "marker mixin for classes allowed among attributes' children"))
(defClass elem-child-node (document-scoped-node)
()
(:metaclass abstract-class)
(:documentation "marker mixin for classes allowed among elements' children"))
(defClass doc-child-node (elem-child-node document-scoped-node)
()
(:metaclass abstract-class)
(:documentation "marker mixin for classes allowed at the document top-level"))
(defClass document-definition-child-object () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass doctype-child-node (document-scoped-node document-definition-child-object)
()
(:metaclass abstract-class)
(:documentation "marker mixin for classes permitted in the dtd."))
(defClass abstract-elem-property-node (document-scoped-node elem-property-node-interface)
()
(:metaclass abstract-class)
(:documentation
"a marker mixin for concrete element properties (attributes and ns-nodes)
and respective reference nodes."))
(defClass annotation () () (:documentation "added for compatibility with 0.950"))
(defClass annotation-node (annotation) () (:documentation "added for compatibility with 0.950"))
(defClass elem-property-node (unamed-node abstract-value-node abstract-elem-property-node
typed-node annotation-node)
((value :initform nil))
(:metaclass abstract-class)
(:documentation
"an abstract class for values which are bound to an element as properties or annotations.
these include attributes and namespaces."))
(defClass value-node (abstract-value-node)
((value :initform nil))
(:metaclass abstract-class)
(:documentation
"an abstract class for value nodes which provide a default <code>NULL</code> value."))
(defClass named-value-node (ncnamed-node value-node)
()
(:metaclass abstract-class)
(:documentation
"the abstract root for classes which combine a name and a value property."))
(defClass abstract-def-node (named-node)
()
(:metaclass abstract-class)
(:documentation
"the abstract class for model nodes which binds the definition of an attribute, element,
notation, or entity."))
(defClass abstract-def-type (abstract-def-node)
()
(:metaclass abstract-class)
(:documentation
"the abstract class of type definitions: attributes, elements, primitive types"))
(defClass abstract-top-level-def-node (abstract-def-node doctype-child-node)
()
(:metaclass abstract-class)
(:documentation
"a marker mixin to indicate that the node is permitted as a top-level definition
in a document type definition."))
;; concrete
(defClass doc-node (entity-delegate abstract-node doc-node-interface)
((root :initform nil :initarg :root :accessor root :accessor element
:type (or abstract-elem-node null)
:documentation
"binds the root element of the document.
this is also called the <em>document element</em>.
it is <em>not</em> the <em>document root</em> - that is the doc-node itself.")
(standalone :accessor standalone :initarg :standalone :initarg :sddecl
:initform t
:documentation
"indicates that an external subset is required to properly decode a document.
the value is ignored by the parser, but it should be set correctly to enable
valid serialization. default is <code>T</code>.")
(version :accessor version :initarg :version :initarg :version-info
:initform nil)
(notations :accessor notations
:initform (make-hash-table) :type hash-table)
(ids :accessor ids
:initform (make-hash-table) :type hash-table)
(general-entities :accessor general-entities
:initform (make-hash-table) :type hash-table)
(parameter-entities :initarg :parameter-entities :accessor parameter-entities
:initform (make-hash-table) :type hash-table)
(types :accessor types
:initform (make-hash-table) :type hash-table)
(attributes :initform nil :accessor attributes
:type list :documentation
"binds attlist definition instances. these are present for documentation
purposes only: the effective definitions are integrated in the element
type definitions.")
(validate :initform nil :initarg :validate :accessor validate?)
(namespaces :initform nil :initarg :namespaces :accessor namespaces
:documentation
"bind the set of namespaces present within the document.")))
(defun document-element (document) (root document))
(defun (setf document-element) (element document) (setf (root document) element))
(defClass document-type-declaration-information-node (entity-information-node document-scoped-node)
())
(defClass abstract-elem-node (ordinal-node doc-child-node elem-node-interface)
((ordinality :initform (when *element-count* (incf *element-count*))))
(:metaclass abstract-class)
(:documentation
"the abstract form for element nodes.
extends the <code>elem-node-interface</code> to provide slots for ordinality and document.
the graph interface (name parent children attributes namespaces) remains to be implemented
by specializers."))
(defClass elem-node (unamed-node typed-node abstract-elem-node)
((children :initform nil :type list)
(attributes :initform nil :initarg :attributes :accessor attributes
:type list)
(namespaces :initform nil :initarg :namespaces :accessor namespaces
:type list)
(valid)))
(defClass ref-elem-node (ref-node abstract-elem-node) ())
(defClass ext-subset-node (entity-delegate abstract-node)
((children :initform nil :initarg :defs :accessor defs)))
(defClass abstract-attr-node () () (:metaclass abstract-class))
(defClass attribute-node () () (:documentation "added for compatibility with 0.950"))
(defClass attr-node (elem-property-node abstract-attr-node attribute-node)
()
(:metaclass abstract-class))
(defClass normalizing-attr-node (attr-node)
()
(:metaclass abstract-class))
(defClass trimming-attr-node (attr-node)
()
(:metaclass abstract-class))
(defClass namespace-declaration () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass abstract-ns-node (namespace-declaration) () (:metaclass abstract-class))
(defClass nsdecl-node () ()
(:documentation "for 0.950 compatibility"))
(defClass ns-node (elem-property-node abstract-ns-node duration-scoped-node nsdecl-node)
((name :initarg :prefix :reader prefix)
(children :initform nil)
(value :initform nil :initarg :uri :initarg :namespace-name)
(namespace :initform nil :initarg :namespace :reader namespace)))
(defClass ref-elem-property-node (ref-node abstract-elem-property-node) ())
(defClass ref-attr-node (ref-elem-property-node abstract-attr-node) ())
(defClass ref-ns-node (ref-elem-property-node abstract-ns-node) ())
(defClass decimal-attr-node (attr-node) () )
(defClass double-attr-node (attr-node) () )
(defClass entity-attr-node (trimming-attr-node) () )
(defClass entities-attr-node (attr-node) () )
(defClass enumerated-attr-node (trimming-attr-node)
()
(:metaclass abstract-class))
(defclass enumeration-attr-node (enumerated-attr-node string-attr-node) () )
(defClass id-attr-node (trimming-attr-node) () )
(defClass id-ref-attr-node (trimming-attr-node) () )
(defClass id-refs-attr-node (attr-node) () )
(defClass nmtoken-attr-node (trimming-attr-node) () )
(defClass nmtokens-attr-node (attr-node) () )
(defClass notation-attr-node (enumerated-attr-node) () )
(defClass qname-attr-node (attr-node) () )
(defClass recur-dur-attr-node (attr-node) () )
(defClass string-attr-node (normalizing-attr-node) () )
(defClass time-attr-node (attr-node) () )
(defClass uri-ref-attr-node (attr-node) () )
(defClass pi-node (named-node abstract-value-node doc-child-node doctype-child-node)
((value :initform nil)
(name :initarg :target :accessor target))
(:documentation
"a processing instruction binds a </it>target name</it> and a string value.
the value should not include the sequence '?>', but that it not enforced."))
(defClass comment-node (abstract-value-node doc-child-node doctype-child-node)
())
(defClass character-data-node (abstract-value-node doc-child-node)
())
(defClass info-item-node (abstract-node)
())
(defClass ref-node (abstract-value-node ordinal-node)
())
(defClass binary-value (value-node elem-child-node attr-child-node) ())
(defClass bool-value (value-node elem-child-node attr-child-node) ())
(defClass decimal-value (number-value) ())
(defClass double-value (number-value) ())
(defClass entity-value (value-node attr-child-node) ())
(defClass float-value (number-value) ())
(defClass function-value (named-value-node)
((value :initarg :expression :reader expression)))
(defClass id-value (value-node attr-child-node) ())
(defClass id-ref-value (value-node attr-child-node) ())
(defClass notation-value (value-node attr-child-node) ())
(defClass number-value (value-node elem-child-node attr-child-node) ()
(:metaclass abstract-class))
(defClass qname-value (named-value-node attr-child-node)
((name :initarg :local-part :reader local-part)
(value :initform nil :reader qname
:documentation "binds the universal name symbol")
(prefix :initform nil :initarg :prefix :reader prefix)
(uri :initform nil :initarg :uri :reader uri)
(namespace :initform nil :initarg :namespace :reader namespace)))
(defClass recur-dur-value (value-node elem-child-node attr-child-node) ())
(defClass string-value (value-node elem-child-node attr-child-node) ())
(defClass time-dur-value (value-node elem-child-node attr-child-node) ())
(defClass uri-ref-value (named-value-node elem-child-node attr-child-node) ()
(:documentation "wrap an uri instance with an appropriately typed node."))
(defClass qname-context-delegate ()
((qname-context :accessor qname-context :initform nil
:documentation "binds a context to collect and resolve qualified names."))
(:metaclass abstract-class)
(:documentation
"augments definitions which collect qualified names."))
(defClass element-definition () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass element-type-definition () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass doctype-element-definition (element-definition element-type-definition) ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass def-elem-type (doctype-element-definition
unamed-node abstract-def-type abstract-top-level-def-node
qname-context-delegate abstract-value-node
)
((value :initform nil :reader node-validator
:documentation "binds the compiled validator")
(children :initarg :model :accessor model :initform nil
:documentation "binds the bnf content model")
;; (type :initarg :type :reader type)
(node-class :initform nil :initarg :node-class
:documentation "binds the class used to instantiate element nodes of this type")
(properties :initform nil :initarg :properties :accessor properties)
(props-required :initform nil
:documentation
"a bit-mirror for definitions in properties where =1 implies required")
(props-defaulted :initform nil
:documentation
"a bit-mirror for definitions in properties where =1 implies default")))
(defun direct-annotation-model (definition) "0-950" (properties definition))
(defun (setf direct-annotation-model) (model definition) "0-950" (setf (properties definition) model))
(defun annotation-model (definition) "0-950" (properties definition))
(defun content-model (definition) "0-950" (model definition))
(defClass doctype-attlist-definition () () (:documentation "0.950"))
(defClass def-attr (doctype-attlist-definition
abstract-top-level-def-node unamed-node qname-context-delegate
duration-scoped-node)
((children :initarg :attributes :accessor attributes :initform nil))
(:documentation
"a <code>DEF-ATTR</code> collects a set of attribute definitions for a given
element type context."))
(defClass annotation-definition () () (:documentation "0.950"))
(defClass doctype-annotation-definition (annotation-definition) () (:documentation "0.950"))
(defClass def-elem-property-type (unamed-node abstract-def-type abstract-def-node
duration-scoped-node
doctype-annotation-definition)
((children :initform nil :initarg :enumeration :reader enumeration)
(stipulation :initarg :stipulation :initform nil :reader stipulation)
(prototype :initarg :prototype :initform nil :reader prototype))
(:documentation
"for use in the element definition."))
(defClass def-notation (abstract-top-level-def-node entity-information-node)
())
(defClass def-entity (ncnamed-node abstract-top-level-def-node abstract-value-node)
((value :initform nil)
(extent :initform nil :initarg :extent :reader extent
:type (member :static :temporary nil))
(maybe-markup-text :initform :unknown))
(:metaclass abstract-class))
(defClass general-entity-definition () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass def-general-entity (def-entity general-entity-definition) () (:metaclass abstract-class))
(defClass parameter-entity-definition () ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass def-parameter-entity (def-entity parameter-entity-definition) () (:metaclass abstract-class))
(defClass def-internal-entity (def-entity) () (:metaclass abstract-class))
(defClass def-external-entity (entity-delegate def-entity)
((children :initform nil))
(:metaclass abstract-class))
(defClass def-internal-general-entity (def-internal-entity def-general-entity)
())
(defClass def-external-general-entity (def-external-entity def-general-entity)
((notation :initform nil :initarg :notation :reader notation)))
(defClass def-internal-parameter-entity (def-internal-entity def-parameter-entity) ())
(defClass def-external-parameter-entity (def-external-entity def-parameter-entity)
((children :initform nil)))
(defClass type-definition (named) ()
(:documentation "added for compatibility with 0.950 conditions"))
(defClass ref-entity (ref-node named-node attr-child-node)
((expand :initform nil :initarg :expand :accessor expand
:documentation "specifies whether to expand the entity when encoding."))
(:metaclass abstract-class))
(defClass ref-general-entity (ref-entity elem-child-node) () )
(defClass ref-parameter-entity (ref-entity doctype-child-node) () )
(defClass ref-character-entity (ref-entity elem-child-node) ())
(defClass conditional-section (ref-parameter-entity)
()
(:documentation
"a <code>CONDITIONAL-SECTION</code> specializes the behaviour of a pe-reference
and serves as the container for conditional declarations, the presence of which
depend on the respective entites value.
it is produced by parsing external declaration subsets with
pe expansion disabled, and may also be generated programmatically."))
(defClass external-parsed-entity (entity-delegate ref-general-entity)
()
(:documentation
"an <code>EXTERNAL_PARSED-ENTITY</code> acts as a container for an external parsed general
entity. it binds the content sequence and the encoding. it is used to enforce the
structural constraints on the entities content."))
;;
;;
;; model classes
(defClass content-model () ())
(defClass |content-model| (bnfp::bnf-phrase-definition content-model) ())
(defClass |\|-content| (bnfp::bnf-alternative content-list) () )
(defClass content-occurrence () ())
(defClass |?-content| (bnfp::bnf-opt-expr content-occurrence) () )
(defClass |*-content| (bnfp::bnf-rep-expr content-occurrence) () )
(defClass |bounded-content| (bnfp::bnf-qexpr content-occurrence)
((min :initarg :min :initform nil)
(max :initarg :max :initform nil)) )
(defClass |MIXED-content| (|*-content|) () )
(defClass |+-content| (bnfp::bnf-plus-expr content-occurrence) () )
(defClass |content| (bnfp::bnf-one-expr content-occurrence) () )
(defClass content-list () ())
(defClass |,-content| (bnfp::bnf-group content-list) () )
(defClass content-name () ())
(defClass |content-name| (bnfp::bnf-phrase-symbol content-name) () )
(defClass type-name () ())
(defClass |type-name| (bnfp::bnf-nonterminal-symbol type-name) () )
(defClass mixed-atn (bnfp::atn) ())
(defClass element-atn (bnfp::atn) ())
(defMethod name ((instance |content-name|)) (bnfp::bnf-name instance))
(defMethod (setf name) (name (instance |content-name|)) (setf (bnfp::bnf-name instance) name))
(defMethod name ((instance |type-name|)) (bnfp::bnf-name instance))
(defMethod (setf name) (name (instance |type-name|)) (setf (bnfp::bnf-name instance) name))
(defMethod name ((instance |content-model|)) (name (bnfp::bnf-lhs instance)))
(defMethod nonterminal ((instance |content-model|)) (bnfp::bnf-lhs instance))
(defMethod grammar ((instance |content-model|)) (bnfp::bnf-rhs instance))
(defun expressions (x) (bnfp::bnf-expressions x))
(defmethod expression ((x content-occurrence)) (bnfp::bnf-expression x))
(defMethod print-object ((object |content-name|) stream &aux name)
(setf name (and *print-pretty* (bnfp::bnf-name object)))
;; only the special case of PCDATA with other elements gets here
;; ANY and EMPTY never get here -- see below
(cond ((eq name *mixed-name*) (princ "#PCDATA" stream))
(t (call-next-method))))
(defMethod print-object ((object |*-content|) stream &aux expr name)
(setf name (when (and *print-pretty*
(typep (setf expr (bnfp::bnf-expression object)) '|content-name|))
(bnfp::bnf-name expr)))
(cond ((eq name *wild-name*) (princ "ANY" stream))
((eq name *empty-name*) (princ "EMPTY" stream))
((eq name *mixed-name*) (princ "(#PCDATA)" stream))
(t (call-next-method))))
;;
;;
;; walking definition components
(defGeneric walk-model-names (particle function)
;; type declaration data
(:method ((context def-elem-type) (function t))
(setf (name context) (funcall function (name context)))
(walk-model-names (properties context) function)
(walk-model-names (model context) function))
;; generic expression data
(:method ((context t) (function t)) nil)
(:method ((decls list) (function t))
(dolist (decl decls) (walk-model-names decl function)))
;; attribute declaration data
(:method ((context def-elem-property-type) (function t))
(with-slots (prototype) context
(setf (name context) (funcall function (name context)))
(when prototype
(setf (name prototype) (funcall function (name prototype))))))
(:method ((context elem-property-node) (function t))
(with-slots (def) context
(setf (name context) (funcall function (name context)))
(when def (setf (name def) (funcall function (name def))))))
;; content model data
(:method ((context |content-model|) (function t))
(walk-model-names (bnfp::bnf-lhs context) function)
(walk-model-names (bnfp::bnf-rhs context) function))
(:method ((context |\|-content|) (function t))
(walk-model-names (bnfp::bnf-expressions context) function))
(:method ((context |?-content|) (function t))
(walk-model-names (bnfp::bnf-expression context) function))
(:method ((context |*-content|) (function t))
(walk-model-names (bnfp::bnf-expression context) function))
(:method ((context |+-content|) (function t))
(walk-model-names (bnfp::bnf-expression context) function))
(:method ((context |content|) (function t))
(walk-model-names (bnfp::bnf-expression context) function))
(:method ((context |,-content|) (function t))
(walk-model-names (bnfp::bnf-expressions context) function))
(:method ((context |content-name|) (function t))
(setf (bnfp::bnf-name context) (funcall function (bnfp::bnf-name context))))
(:method ((context |type-name|) (function t))
(setf (bnfp::bnf-name context) (funcall function (bnfp::bnf-name context)))))
(defMethod collect-model-names ((model |content-model|) &aux names is-mixed (model-name (name model)))
(walk-model-names model
#'(lambda (name)
(cond ((or (eq name *empty-name*) (eq name *wild-name*))
(push name names)
name)
((eq name *mixed-name*) (setf is-mixed t) name)
(t (push name names) name))))
(when (and (validate? *document*) is-mixed)
(mapl #'(lambda (rest &aux (name (first rest)))
(when (find name (rest rest)
:test #'(lambda (n1 n2)
(and (bnfp::name= n1 n2)
(not (eq n1 model-name)) (not (eq n2 model-name)))))
(|VC: No Duplicate Types| :context model :name (first rest))))
names))
names)
(defMethod collect-model-names ((model bnfp::bnf-expr) &aux names)
(walk-model-names model
#'(lambda (name)
(cond ((or (eq name *empty-name*) (eq name *wild-name*))
(pushnew name names)
name)
((eq name *mixed-name*) name)
(t (pushnew name names) name))))
(nreverse names))
(defGeneric first-model-name (model)
(:method ((model |content-model|))
(first-model-name (bnfp::bnf-rhs model)))
(:method ((model t))
(walk-model-names model #'(lambda (name) (return-from first-model-name name)))))
;;
;;
;; classes for qualified name resolution
(defClass qname-context ()
((name :initarg :name :reader name)
(def :initform nil :initarg :def :reader def :reader definition)
(pass-id :initform nil :accessor pass-id))
(:documentation
"a <code>QNAME-CONTEXT</code> collects the uninterned qnames which are governed by a
given declaration. it is used while reading the document type definition. at the point of
appearance of each declaration a new one is created."))
(defClass def-type-qname-context (qname-context)
((parents :initform nil :accessor parents)
(children :initform nil :accessor children)
(content-names :initarg :content-names :reader content-names)
(attr-nodes :initform nil :initarg :attr-nodes :accessor attr-nodes
:initarg :attributes :accessor attributes)
(ns-nodes :initform nil :initarg :ns-nodes :accessor ns-nodes
:initarg :nsdecl-nodes :accessor nsdecl-nodes
:initarg :namespace-declarations :accessor namespace-declarations)
(successors :initform nil
:documentation
"binds the conceivable successors based on the literal qualified names.")
(ns-cache :initform nil :accessor ns-cache
:documentation "bind results from searching parents"))
(:documentation
"a <code>def-type-QNAME-CONTEXT</code> collects the qualified names which contribute to
an individual element declaration. it is created with the names from the element
declaration proper and augmented with those from related attribute list declarations.
in the process of resolving qualified names to universal names, relations among element
contexts are established to simulate the visibility of prefix/namespace bindings
as specified for the document entity."))
(defClass def-attr-qname-context (qname-context)
((name :writer (setf name))
(attr-nodes :initform nil :initarg :attr-nodes :accessor attr-nodes
:initarg :attributes :accessor attributes)
(ns-nodes :initform nil :initarg :ns-nodes :accessor ns-nodes
:initarg :nsdecl-nodes :accessor nsdecl-nodes
:initarg :namespace-declarations :accessor namespace-declarations)
(assignment :initform nil :accessor assignment))
(:documentation
"a <code>DEF-ATTR-QNAME-CONTEXT</code> collects the qualified names which contribute
to attribute declarations for an element. note that the namespace nodes can be neglected
as the 'xmlns' prefix/namespace binding is static.
in the process of resolving qualified names to universal names, each attribute context
is merged into a element context."))
(defGeneric walk-model-nodes (particle function)
(:documentation
"walk the model tree and apply the function to each node. for 0.950")
(:method ((context element-definition) (function t))
(funcall function context)
(walk-model-nodes (annotation-model context) function)
(walk-model-nodes (content-model context) function))
(:method ((context t) (function t)) nil)
(:method ((decls list) (function t))
(dolist (decl decls) (walk-model-nodes decl function)))
(:method ((node ext-subset-node) (function t))
(walk-model-nodes (children node) function))
(:method ((context annotation-definition) (function t))
(with-accessors ((prototype prototype)) context
(funcall function context)
(when prototype
(funcall function prototype))))
(:method ((context annotation) (function t))
(with-accessors ((definition definition)) context
(funcall function context)
(when definition(funcall function definition))))
(:method ((context def-type-qname-context) (function t))
(funcall function context)
(mapcar #'(lambda (def) (walk-model-nodes def function)) (namespace-declarations context))
(let ((*default-namespace-is-visible* nil))
(mapcar #'(lambda (def) (walk-model-names def function)) (attributes context)))
(walk-model-nodes (def context) function))
;; content model data
(:method ((context content-model) (function t))
(walk-model-nodes (nonterminal context) function)
(walk-model-nodes (grammar context) function))
(:method ((context content-list) (function t))
(walk-model-nodes (expressions context) function))
(:method ((context content-occurrence) (function t))
(walk-model-nodes (expression context) function))
(:method ((context content-name) (function t))
(funcall function context))
(:method ((context type-name) (function t))
(funcall function (name context))))
;;
;;
;; types and constructors
;; nb. no constructors defined for the abstract classes...
(defMacro defClassConstructor (name)
`(defun ,(intern (concatenate 'string "MAKE-" (string name)))
(&rest initargs)
(declare (dynamic-extent initargs))
(apply #'make-instance
,(intern (concatenate 'string "*CLASS." (string name) "*"))
initargs)))
(defMacro defClassConstructors (&rest names)
`(progn
,@(mapcar #'(lambda (name)
`(defParameter ,(intern (concatenate 'string "*CLASS." (string name) "*"))
(find-class ',name)))
names)
,@(mapcar #'(lambda (name) `(defClassConstructor ,name)) names)))
(defMacro defTypePredicate (name)
`(defun ,(intern (concatenate 'string "IS-" (string name))) (x)
(typep x ',name)))
(defvar *export-output* )
(defMacro defTypePredicates (&rest names)
(when (boundp '*export-output*)
(mapcar #'(lambda (names)
(format *export-output* "~%~{~s~^ ~}" names))
(sort (mapcar #'(lambda (name)
(list* (string name)
(concatenate 'string "IS-" (string name))
(unless (string= "ABSTRACT" name :end2 (min (length (string name)) 8))
(list (concatenate 'string "*CLASS." (string name) "*")
(concatenate 'string "MAKE-" (string name))))))
names)
#'string< :key #'first)))
`(progn ,@(mapcar #'(lambda (name)
`(defTypePredicate ,name)) names)))
(defClassConstructors
doc-node elem-node ns-node ext-subset-node
decimal-attr-node double-attr-node entity-attr-node entities-attr-node
enumeration-attr-node id-attr-node id-ref-attr-node id-refs-attr-node
nmtoken-attr-node nmtokens-attr-node notation-attr-node
qname-attr-node recur-dur-attr-node string-attr-node time-attr-node
uri-ref-attr-node
pi-node comment-node info-item-node character-data-node
document-type-declaration-information-node entity-information-node
string-value bool-value float-value double-value decimal-value
time-dur-value recur-dur-value binary-value uri-ref-value id-value id-ref-value
qname-value entity-value notation-value function-value
def-attr def-elem-property-type def-elem-type def-notation
def-internal-general-entity def-external-general-entity
ref-node
def-internal-parameter-entity def-external-parameter-entity
ref-parameter-entity ref-general-entity ref-character-entity
conditional-section external-parsed-entity)
(defTypePredicates
doc-node abstract-elem-node elem-node ext-subset-node ordinal-node
elem-property-node abstract-elem-property-node
abstract-attr-node attr-node abstract-ns-node ns-node
def-elem-property-type
elem-child-node attr-child-node doctype-child-node doc-child-node
decimal-attr-node double-attr-node entity-attr-node entities-attr-node
enumeration-attr-node id-attr-node id-ref-attr-node id-refs-attr-node
nmtoken-attr-node nmtokens-attr-node notation-attr-node
qname-attr-node recur-dur-attr-node string-attr-node time-attr-node
uri-ref-attr-node
pi-node comment-node info-item-node character-data-node
document-type-declaration-information-node entity-information-node
value-node string-value bool-value number-value float-value double-value decimal-value
time-dur-value recur-dur-value binary-value uri-ref-value id-value id-ref-value
qname-value entity-value notation-value function-value
abstract-def-node abstract-top-level-def-node abstract-def-type
def-attr def-elem-type def-notation def-entity
def-internal-entity def-external-entity def-parameter-entity def-general-entity
def-internal-general-entity def-external-general-entity
def-internal-parameter-entity def-external-parameter-entity
ref-node ref-entity
ref-parameter-entity ref-general-entity ref-character-entity
conditional-section external-parsed-entity
qname-context)
(defun element-p (x) (is-abstract-elem-node x))
(defun id-attr-node-p (x) (is-id-attr-node x))
(defun nsdecl-node-p (x) (is-ns-node x))
;;
;;
;; supplementary accessors
(defMethod value ((node value-node))
(with-slots (children value) node
(or value (setf value (value-string children)))))
(defMethod parent ((node string)) nil)
(defMethod children ((node string)) nil)
(defGeneric validate? (node)
(:documentation "bound directly to document nodes. other nodes resolve relative to the container, or yield nil.")
(:method ((node document-scoped-node)) (validate? (document node)))
(:method ((node null)) nil)
(:method ((node t)) (warn "validation not defined for node: ~s." node) nil))
(defun validate-p (x) (validate? x))
#|
;; the value generators for entites are only marginally useful.
;; the replacement mechanism uses the input sequence stored in the child slot
;; rather than the string which would have been produced here
(defMethod value ((node ref-parameter-entity))
(with-slots (value name) node
(or value (setf value (parameter-entity-value name)))))
(defMethod value ((node ref-general-entity))
(with-slots (value name) node
(or value (setf value (general-entity-value name)))))
(defMethod value ((node def-internal-entity))
(with-slots (children value) node
(or value (setf value (value-string children)))))
(defMethod value ((node def-external-entity) &aux (uri (uri node)))
(with-slots (children value) node
(if value
value
(setf children nil
value (when uri
(read-external-entity uri))))))
|#
(defMethod value ((node entities-attr-node))
(with-slots (children value document) node
(cond (value)
(children
(setf value (mapcar #'(lambda (name &aux entity)
(unless (is-ncname name)
(|VC: ID| :name (name node) :value value
:detail "not an NCName"))
(setf name (intern-name name *null-namespace*))
(when document
(when (setf entity (find-def-general-entity name document))
(unless (and (is-def-external-general-entity entity)
(notation entity))
(|VC: Entity Name| :name name))))
name)
(split-string (value-string children)
#(#\space #\return #\linefeed #\tab))))))))
(defMethod value ((node entity-attr-node) &aux entity)
(with-slots (children value document) node
(cond (value)
(t
(unless (is-ncname (setf value
(normalize-value node (value-string children))))
(|VC: Entity Name| :context (name node) :name value
:detail "not an NCName"))
(setf value (intern-name value *null-namespace*))
(when document
(when (setf entity (find-def-general-entity value document))
(unless (and (is-def-external-general-entity entity)
(notation entity))
(|VC: Entity Name|
:context (name node) :name value
:detail "must name an unparsed entity"))))))))
(defMethod value ((node id-attr-node))
(with-slots (children value) node
(cond (value)
(children
(unless (is-ncname (setf value
(normalize-value node (value-string children))))
(|VC: ID| :name (name node) :value value
:detail "not an NCName"))
(setf value (intern-name value *null-namespace*))))))
(defMethod value ((node id-ref-attr-node))
(with-slots (children value) node
(cond (value)
(children
(unless (is-ncname (setf value
(normalize-value node (value-string children))))
(|VC: ID| :name (name node) :value value
:detail "not an NCName"))
(setf value (intern-name value *null-namespace*))))))
(defMethod value ((node id-refs-attr-node))
(with-slots (children value) node
(cond (value)
(children
(setf value (mapcar #'(lambda (name)
(unless (is-ncname name)
(|VC: ID| :name (name node) :value value
:detail "not an NCName"))
(intern-name name *null-namespace*))
(split-string (value-string children)
#(#\space #\return #\linefeed #\tab))))))))
(defMethod value ((node nmtoken-attr-node))
(with-slots (children value) node
(cond (value)
(children
(unless (is-namechardata (setf value
(normalize-value node (value-string children))))
(|VC: Name Token| :name (name node) :value value
:detail "not a Name"))
(setf value (intern-name value *null-namespace*))))))
(defMethod value ((node nmtokens-attr-node))
(with-slots (children value) node
(cond (value)
(children
(setf value (mapcar #'(lambda (name)
(unless (is-namechardata name)
(|VC: Name Token|
:name (name node) :value name
:detail "not an Name"))
(intern-name name *null-namespace*))
(split-string (value-string children)
#(#\space #\return #\linefeed #\tab))))))))
(defMethod value ((node notation-attr-node))
(with-slots (children value def) node
(cond (value)
(children
(setf value (normalize-value node (value-string children)))
(unless (is-namechardata value)
(|VC: Name Token| :name (name node) :value value
:detail "not an Name"))
(setf value (intern-name value *null-namespace*))
(when def
(unless (find value (enumeration def))
(|VC: Notation Attributes| :name value))))
(t
(|VC: Name Token| :name (name node) :value value
:detail "not an Name")))))
(defMethod value ((node enumeration-attr-node))
(with-slots (children value def) node
(cond (value)
(children
(call-next-method)
(when def
(unless (find value (enumeration def) :test #'string=)
(|VC: Enumeration| :name value)))))))
(defMethod value ((node string-attr-node))
(with-slots (children value) node
(if value value
(setf value (normalize-value node (value-string children))))))
(defmethod (setf value) ((new-value string) (node string-attr-node))
(with-slots (children value) node
(setf children (list new-value)
value new-value)))
(defMethod value ((node ns-node))
(with-slots (children value) node
(if value value
(setf value (normalize-value node (value-string children))))))
(defMethod uri ((node ns-node))
(value node))
(defMethod namespace-name ((node ns-node))
(value node))
(defMethod value ((node pi-node))
(with-slots (value children) node
(or value (setf value (or (first children) "")))))
(defMethod (setf value) ((new-value string) (node pi-node))
(with-slots (value children) node
(setf value new-value
children (list new-value))))
(defMethod (setf value) ((new-value t) (node pi-node))
(assert (typep new-value 'string)))
(defMethod value ((node uri-ref-value))
(with-slots (value children) node
(if value value
(setf value (make-uri (string-trim #(#\space) (value-string children)) *xml-base*)))))
;;
;; normalizing reduces all space to a single character, trimming, in addition,
;; removes initial and trailing space
;; nb. in order to keep the model independent of the respective parser, a simple subsequence
;; is generated and no attempt is made to return string buffers, as the only xml parser uses them.
(defGeneric normalize-value (node value)
(:documentation
"value normalization is specified by the XML standard.
it is performed when a value is generated from children, which is the case
when a node is generated by the parser.")
(:method ((node attr-node) (value t)) value))
(defMethod normalize-value ((node normalizing-attr-node) (value string)
&aux (to 0) (from 0) (end (length value)) char space?)
(loop (when (>= from end) (return))
(cond ((xml-space? (setf char (schar value from)))
(setf (schar value to) #\space)
(unless space?
(incf to)
(setf space? t)))
(t
(setf (schar value to) char)
(setf space? nil)
(incf to)))
(incf from))
(cond ((= to end) value)
(t (subseq value 0 to))))
(defun normalize-and-trim-string (value &aux (to 0) (from 0) (end (length value)) char space?)
(loop (when (>= from end) (return))
(cond ((xml-space? (setf char (schar value from)))
(setf (schar value to) #\space)
(when (and (not space?) (> to 0))
(incf to)
(setf space? t)))
(t
(setf (schar value to) char)
(setf space? nil)
(incf to)))
(incf from))
(when (and (> to 0) (xml-space? (schar value (1- to))))
(decf to))
(cond ((= to end) value)
(t (subseq value 0 to))))
(defMethod normalize-value ((node trimming-attr-node) (value string))
(normalize-and-trim-string value))
(defMethod normalize-value ((node ns-node) (value string))
(normalize-and-trim-string value))
;(normalize-value (allocate-instance (find-class 'string-attr-node)) " d a ")
;(normalize-value (allocate-instance (find-class 'nmtoken-attr-node)) " this-gets-normalized ")
(defMethod (setf parent) :after
((parent elem-node) (instance attr-node))
;; generate the value in order to enforce constraints. this is deferred until
;; the attribute is bound to an element in order to use the context when generating
;; interned values.
(when (validate? instance)
(value instance)))
(defMethod (setf parent) :after
((parent elem-node) (instance id-attr-node) &aux (id (value instance)))
;; bind the id within the document
(with-slots (document) instance
(when (setf document (document parent))
(when (gethash id (ids document))
(|VC: ID| :name (name instance) :value id :detail "not unique"))
(setf (gethash id (ids document)) instance))))
;;
;;
;; encapsulated children are expendable for attribute/ns nodes and for value
;; nodes themselves.
;; children generated as parse artifacts or may be asserted for serialization.
;; the value slot dominates and modifies the children implicitly.
(defMethod (setf value) ((new-value string) (node value-node))
(with-slots (children value) node
(setf value new-value)
(setf children (list new-value))))
(defMethod (setf value) ((new-value value-node) (node value-node))
(with-slots (children value) node
(setf value new-value)
(setf children (list (value-string new-value)))))
;;
;;
;; entity information delegation
(defMethod entity-info ((node entity-delegate))
(with-slots (entity-info) node
(or entity-info
(setf entity-info (make-instance 'entity-information-node)))))
(defMethod name ((node doc-node))
(with-slots (entity-info) node
(when entity-info (name entity-info))))
(defMethod (setf name) (value (node doc-node))
(setf (name (entity-info node)) value))
(defMethod uri ((node entity-delegate))
(with-slots (entity-info) node
(when entity-info (uri entity-info))))
(defMethod (setf uri) (value (node entity-delegate))
(setf (uri (entity-info node)) value))
(defMethod system-id ((node entity-delegate))
(with-slots (entity-info) node
(when entity-info (system-id entity-info))))
(defMethod (setf system-id) (value (node entity-delegate))
(setf (system-id (entity-info node)) value))
(defMethod (setf system-id) :after ((value t) (node entity-information-node))
(with-slots (uri system-id public-id) node
(setf uri (resolve-entity-identifiers public-id system-id *xml-base*))))
(defMethod public-id ((node entity-delegate))
(with-slots (entity-info) node
(when entity-info (public-id entity-info))))
(defMethod (setf public-id) (value (node entity-delegate))
(setf (public-id (entity-info node)) value))
(defMethod (setf public-id) :after ((value t) (node entity-information-node))
(with-slots (uri system-id public-id) node
(setf uri (resolve-entity-identifiers public-id system-id *xml-base*))))
(defMethod encoding ((node entity-delegate))
(with-slots (entity-info) node
(when entity-info (encoding entity-info))))
(defMethod (setf encoding) (value (node entity-delegate))
(setf (encoding (entity-info node)) value))
(defmethod encoding ((node document-scoped-node))
(encoding (document node)))
(defgeneric (setf encoding) (encoding entity-information-node)
(:method ((encoding string) (node entity-information-node) &aux canonical-encoding)
(cond
((setf canonical-encoding (canonical-encoding encoding))
(setf (slot-value node 'encoding) canonical-encoding))
(t
(error "illegal encoding: ~s." encoding))))
(:method ((encoding symbol) (node entity-information-node) &aux canonical-encoding)
(cond
((setf canonical-encoding (canonical-encoding encoding))
(setf (slot-value node 'encoding) canonical-encoding))
(t
(error "illegal encoding: ~s." encoding)))))
(defMethod version ((node entity-delegate))
(with-slots (entity-info) node
(when entity-info (version entity-info))))
(defMethod (setf version) (value (node entity-delegate))
(setf (version (entity-info node)) value))
;;
;;
;; reference node access delegation
(defMacro defDelegateMethod (name ((instance class)) slot)
`(progn (defMethod ,name ((,instance ,class))
(with-slots (,slot) ,instance (,name ,slot)))
(defMethod (setf ,name) (new-value (,instance ,class))
(with-slots (,slot) ,instance (setf (,name ,slot) new-value)))))
(defDelegateMethod children ((node ref-elem-node)) value)
(defDelegateMethod name ((node ref-elem-node)) value)
(defDelegateMethod attributes ((node ref-elem-node)) value)
(defDelegateMethod def ((node ref-elem-node)) value)
(defDelegateMethod namespaces ((node ref-elem-node)) value)
(defDelegateMethod valid ((node ref-elem-node)) value)
(defDelegateMethod children ((node ref-elem-property-node)) value)
(defDelegateMethod name ((node ref-elem-property-node)) value)
(defDelegateMethod def ((node ref-elem-property-node)) value)
(defDelegateMethod value ((node ref-elem-property-node)) value)
#+sbcl(make-instance 'ref-ns-node)
(defDelegateMethod namespace ((node ref-ns-node)) value)
;;
;;
;; node cloning. for attributes
(defMethod clone-node
((instance abstract-node) &rest initargs &aux new)
(declare (dynamic-extent initargs))
(setf new (allocate-instance (class-of instance)))
;; initialize overriding slot values.
;; do this first, to inhibit side-effects from copying
(when initargs (apply #'shared-initialize new nil initargs))
(copy-node instance new)
new)
(defMethod clone-node ((instance string) &key) instance)
(defMethod clone-node ((nodes list) &rest initargs)
(mapcar #'(lambda (x) (apply #'clone-node x initargs)) nodes))
(defGeneric copy-node (from to)
(:documentation
"copy slot values from one node to another.
slots with bound values are left unchanged.")
(:method-combination progn :most-specific-last)
(:method progn ((from abstract-node) (to abstract-node))
(unless (slot-boundp to 'parent)
(setf (slot-value to 'parent) nil))
(unless (slot-boundp to 'children)
(setf (slot-value to 'children) (clone-node (children from)))))
(:method progn ((from typed-node) (to typed-node))
(unless (slot-boundp to 'def)
(setf (slot-value to 'def) (slot-value from 'def))))
(:method progn ((from named-node) (to named-node))
(unless (slot-boundp to 'name)
(setf (slot-value to 'name) (slot-value from 'name))))
(:method progn ((from ns-node) (to ns-node))
(unless (slot-boundp to 'value)
(setf (slot-value to 'value) (slot-value from 'value)))
(unless (slot-boundp to 'namespace)
(setf (slot-value to 'namespace) (slot-value from 'namespace))))
(:method progn ((from attr-node) (to attr-node))
(unless (slot-boundp to 'value)
(setf (slot-value to 'value) (slot-value from 'value)))))
;;
;;
;; constituent management for a document maintains the relation between the children
;; and the root node. see also the respective check-constraint method
(defMethod nodes ((node doc-node))
"for use with path interpretation"
(children node))
(defMethod (setf nodes) (new-value (doc doc-node))
(setf (children doc) new-value))
(defMethod (setf children) ((children sequence) (doc doc-node))
(with-slots (root) doc
(setf root (find-if #'is-abstract-elem-node children))
(call-next-method)))
(defGeneric document (node)
(:method ((node doc-node)) node)
(:method ((node t)) nil))
(defMethod def ((node elem-node) &aux document)
(with-slots (def name) node
(or (call-next-method)
(setf def (when (and name (setf document (document node)))
(find-def-elem-type name document))))))
(defGeneric definition (x)
(:method ((x t)) (def x)))
;;
;;
;; initialize property bits in a type definition
(defMethod is-required ((def def-elem-property-type))
(eq (stipulation def) :REQUIRED))
(defMethod is-implied ((def def-elem-property-type))
(eq (stipulation def) :IMPLIED))
(defMethod is-fixed ((def def-elem-property-type))
(eq (stipulation def) :FIXED))
(defMethod is-defaulted ((def def-elem-property-type))
(with-slots (prototype) def
(and prototype (children prototype))))
(defMethod is-required ((node elem-property-node))
(with-slots (def) node (when def (is-required def))))
(defMethod is-implied ((node elem-property-node))
(with-slots (def) node (when def (is-implied def))))
(defMethod is-fixed ((node elem-property-node))
(with-slots (def) node (when def (is-fixed def))))
(defMethod is-defaulted ((node elem-property-node))
(with-slots (children) node
children))
(defMethod props-defaulted ((def def-elem-type))
(with-slots (properties props-defaulted) def
(or props-defaulted
(setf props-defaulted
(make-array (length properties) :element-type 'bit
:initial-contents
(mapcar #'(lambda (def) (if (is-defaulted def) 1 0))
properties))))))
(defMethod props-required ((def def-elem-type))
(with-slots (properties props-required) def
(or props-required
(setf props-required
(make-array (length properties) :element-type 'bit
:initial-contents
(mapcar #'(lambda (def) (if (is-required def) 1 0))
properties))))))
(defGeneric name-symbol (name)
(:method ((name symbol))
(if (keywordp name) (intern (string name) *package*) name))
(:method ((name uname))
(intern (local-part name)
(let* ((namespace (namespace name))
(package-name (namespace-name namespace)))
(if (eq namespace *null-namespace*)
*package*
(or (find-package package-name)
(error "package not found: ~s." package-name)))))))
(defGeneric find-node-class (name)
(:method ((name symbol)) (find-class name nil))
(:method ((name uname)) (find-node-class (ignore-errors (name-symbol name)))))
(defMethod node-class ((def def-elem-type))
(with-slots (node-class name) def
(or node-class
(cond ((and *specialize-elem-node*
(setf node-class (find-node-class name))
(subtypep (class-name node-class) 'abstract-elem-node))
node-class)
(t
(setf node-class *class.elem-node*))))))
;(trace node-class)
;(trace xmlp:construct-element-node)
;;
;;
;; initialization
(defMethod initialize-instance
((instance entity-delegate) &rest initargs
&key entity-info uri
system-literal (system-id system-literal)
pubid-literal (public-id pubid-literal)
encoding-decl (encoding encoding-decl)
version-info (version version-info))
;; keep name in sync. for doc-node this becomes the only binding
(when (listp entity-info)
(setf entity-info (apply #'make-entity-information-node entity-info)))
(when (is-entity-information-node entity-info)
(when uri (uri entity-info) uri)
(when system-id (setf (system-id entity-info) system-id))
(when public-id (setf (public-id entity-info) public-id))
(when encoding (setf (encoding entity-info) encoding))
(when version (setf (version entity-info) version)))
(apply #'call-next-method instance :entity-info entity-info initargs))
(defMethod initialize-instance
((instance entity-information-node) &key (defaults *xml-base*))
(with-slots (uri system-id public-id) instance
(call-next-method)
;; generate the uri from the system and public identifiers
(unless uri
(setf uri (resolve-entity-identifiers public-id system-id defaults)))))
(defMethod initialize-instance
((instance doc-node) &rest initargs
&key declarations children (root (find-if #'is-abstract-elem-node children))
notations ids general-entities parameter-entities types attributes)
;; integrate definitions for notation, entities and types.
;; note that the attributes informational and thus not integrated. the effective
;; definitions are in the types
(apply #'call-next-method instance
:root root :children (or children (when root (list root)))
initargs)
(when root (setf (parent root) instance))
(flet ((local-bind-definition (def) (bind-definition def instance)))
(etypecase notations
(hash-table (setf (notations instance) notations))
(cons (map nil #'local-bind-definition notations))
(null (map-node-by-type #'is-def-notation #'bind-definition declarations)))
(etypecase ids
(hash-table (setf (ids instance) ids))
(null t))
(etypecase general-entities
(hash-table (setf (general-entities instance) general-entities))
(cons (map nil #'local-bind-definition general-entities))
(null (map-node-by-type #'is-def-general-entity #'bind-definition declarations)))
(etypecase parameter-entities
(hash-table (setf (parameter-entities instance) general-entities))
(cons (map nil #'local-bind-definition parameter-entities))
(null (map-node-by-type #'is-def-parameter-entity #'bind-definition declarations)))
(etypecase types
(hash-table (setf (types instance) types))
(cons (map nil #'local-bind-definition types))
(null (map-node-by-type #'is-def-elem-type #'bind-definition declarations)))
(setf (attributes instance)
(etypecase attributes
(cons attributes)
(null (collect-attribute-declarations declarations))))
))
(defMethod initialize-instance
((instance elem-node) &rest initargs
&key
(attributes nil attributes-p)
(namespaces nil namespaces-p)
(children nil children-p))
(apply #'call-next-method instance
:children nil
initargs)
(when attributes-p (setf (attributes instance) attributes))
(when namespaces-p (setf (namespaces instance) namespaces))
(when children-p (setf (children instance) children)))
(defMethod (setf attributes) :before (attributes (instance elem-node))
(dolist (n attributes)
(etypecase n
(attr-node (setf (parent n) instance)))))
(defMethod (setf namespaces) :before (namespaces (instance elem-node))
(dolist (n namespaces)
(etypecase n
(ns-node (setf (parent n) instance)))))
(defMethod (setf children) :after (children (instance elem-node))
(declare (special |VC: Element Content|))
(slot-makunbound instance 'valid)
(dolist (n children)
(etypecase n
(elem-child-node (setf (parent n) instance))
(string )))
(when (validate? instance)
(check-constraint |VC: Element Content| instance)))
(defMethod initialize-instance :after
((instance ns-node) &key)
"upon instantiation, as ns-node generates the effective namespace name and ensures
that it exists."
(declare (special |NSC: Prefix Immutable|))
(with-slots (children value namespace name) instance
(when (string= (local-part name) *xmlns-prefix-namestring*)
(setf name *default-namespace-attribute-name*))
(when namespace
(setf value (namespace-name namespace)))
(etypecase value
(null
(setf value (value-string children)))
(string
(unless (and (stringp (first children))
(string= (first children) value)
(null (rest children)))
(setf children (list value)))))
(unless namespace
(setf namespace (find-namespace value :if-does-not-exist :create)))
(check-constraint |NSC: Prefix Immutable| instance)))
#| 20010501, now in the parser only. in constructors for type and attr defs
(defMethod initialize-instance :after
((instance abstract-top-level-def-node) &key)
;; cache declarations within each given physical entity
(push instance *entity-declarations*))
|#
(defMethod initialize-instance :after
((instance def-elem-property-type) &key)
(with-slots (prototype children) instance
(when prototype (setf (def prototype) instance))
;; 20010611 xml-V10-2e-errata#E2
(mapl #'(lambda (values)
(when (find (first values) (rest values) :test #'bnfp::name=)
(|VC: No Duplicate Tokens| :context instance :name (first values))))
children)))
(defMethod initialize-instance :after
((instance def-attr) &key)
(with-slots (children) instance
(dolist (def children)
(setf (parent def) instance))))
;; nb, it would be nicer to note the when the entity is bound and to replace them _and_ longer
;; entities which encode character entities with the effective character entity.
;; the would require that the tokenizer recognize character entity instances.
(defMethod initialize-instance :after
((instance def-internal-entity) &key)
(with-slots (children) instance
;; normalize and constraint the entity value
(when (stringp children)
(setf children (map 'list #'char-code children)))
;; (print (list children (= 1 (length children)) (xml-markupchar? (or (first children) 0))))
(when (and (= 1 (length children)) (xml-markupchar? (first children)))
(setf children (map 'list #'char-code (format nil "&#~d;" (first children)))))))
;;
;;
;;
(defMethod print-object ((node named-node) stream)
(print-unreadable-object (node stream :type t :identity t)
(write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)))
(defMethod print-object ((node doc-node) stream &aux uri)
(print-unreadable-object (node stream :type t :identity t)
(if (slot-boundp node 'entity-info)
(if (setf uri (uri node))
(write-string (uri-namestring uri) stream)
(write-string "<no uri>" stream))
(write-string "<no entity info>" stream))))
(defMethod print-object ((instance qname-value) stream)
(with-slots (namespace name) instance
(format stream "{~@[~a~]}~a" (when namespace (namespace-name namespace)) name)))
(defMethod print-object ((node elem-node) stream)
(print-unreadable-object (node stream :identity t :type t)
(format stream "~s~@[ ~s~]"
(when (slot-boundp node 'name) (slot-value node 'name))
(when (slot-boundp node 'ordinality) (slot-value node 'ordinality)))))
(defMethod print-object ((node attr-node) stream)
(print-unreadable-object (node stream :identity t :type t)
(write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)))
(defMethod print-object ((node ns-node) stream)
(print-unreadable-object (node stream :identity t :type t)
(write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)
(write-string " -> " stream)
(write (when (or (slot-boundp node 'value) (slot-boundp node 'children)) (value node))
:stream stream)))
(defMethod print-object ((instance pi-node) stream &aux value trimmed)
(print-unreadable-object (instance stream :type t :identity t)
(prin1 (name instance) stream)
(setf value (value instance))
(write-string " '" stream)
(dotimes (i (length value))
(write-char (char value i) stream)
(when (> i 16) (setf trimmed t) (return)))
(if trimmed
(write-string "..." stream)
(write-char #\' stream))))
(defMethod print-object ((instance def-internal-entity) stream
&aux children value)
(print-unreadable-object (instance stream :type t :identity t)
(prin1 (name instance) stream)
(cond ((setf children (children instance))
(write-string " '" stream)
(let ((i 0))
(block print-trimmed
(map nil #'(lambda (c)
(when (>= (incf i) 16) (return-from print-trimmed))
(write-char (code-char c) stream))
children))
(when (>= i 16)
(write-string "..." stream)))
(write-char #\' stream))
((setf value (slot-value instance 'value))
(format stream " '~a'" value)))))
(defMethod print-object ((node def-elem-type) stream
&aux (*print-pretty* t) (*print-right-margin* 1024))
(with-slots (name children) node
(print-unreadable-object (node stream :type t :identity t)
(write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)
(if (typep children '|content-model|)
(princ children stream)
(format stream " ~a" children)))))
(defMethod print-object ((node def-attr) stream)
(print-unreadable-object (node stream :type t :identity t)
(format stream "~/xqdm:print-qname/ ~(~/xqdm:print-qname/~^ ~)"
(when (slot-boundp node 'name) (slot-value node 'name))
(when (slot-boundp node 'children) (slot-value node 'children)))))
(defMethod print-qname ((node named-node) (stream stream) &rest args)
(declare (dynamic-extent args))
(apply #'print-qname stream (name node) args))
(defMethod print-qname ((stream stream) (node named-node) &rest args)
(declare (dynamic-extent args))
(apply #'print-qname stream (name node) args))
(defMethod print-qname ((stream stream) (name abstract-name) &rest args)
(declare (ignore args))
(let ((prefix (prefix name))
(namespace (namespace-name name))
(extent (qname-extent name))
(local-part (local-part name)))
(etypecase namespace
(nameset (setf namespace (name namespace)))
(nameset-tokenizer (setf namespace (name namespace)))
(null t)
(string t))
(if namespace
(format stream "{~a}~a" namespace local-part)
(format stream "#~@[~a:~]~a" prefix local-part))
(when extent
(format stream "[~a]" extent))
name))
(defMethod print-qname ((name abstract-name) (stream stream) &rest args)
(declare (dynamic-extent args))
(apply #'print-qname stream name args))
(defGeneric print-ns-node (stream node &rest args)
(:method ((stream stream) (instance ns-node) &rest args)
(declare (ignore args))
(with-slots (name value) instance
(if *print-pretty*
(format stream "[~a~@[/~s~]]" name value)
(print-unreadable-object (instance stream :type t :identity t)
(format stream "~a~@[/~s~]"
name value)))))
(:method ((instance ns-node) (stream stream) &rest args)
(declare (dynamic-extent args))
(apply #'print-ns-node stream instance args)))
(defParameter *context-print-level* 0)
(defMethod print-content ((instance def-type-qname-context) stream)
(with-slots (name parents children content-names attr-nodes ns-nodes) instance
(format stream "~/xqdm:print-qname/" name)
(if (slot-boundp instance 'parents)
(format stream " (^:~{ ~/xqdm:print-qname/~})" (mapcar #'name parents))
(write-string " (^: #<UNBOUND>)" stream))
(format stream " (@:~{ ~/xqdm:print-qname/~})" (mapcar #'name attr-nodes))
(let ((*print-pretty* t))
(format stream " (ns:~{ ~/xqdm:print-ns-node/~})" ns-nodes))
(format stream " (m:~{ ~/xqdm:print-qname/~})" content-names)
(when children
(let ((*context-print-level* (+ *context-print-level* 2)))
(if *print-pretty*
(format stream "~{~%~a~}" children)
(format stream " ->(~{~/xqdm:print-qname/~^ ~})"
(mapcar #'name children)))))))
(defMethod print-content ((instance def-attr-qname-context) stream
&aux (*print-pretty* t))
(with-slots (name attr-nodes ns-nodes assignment) instance
(format stream "~/xqdm:print-qname/" name)
(format stream " (@:~{ ~/xqdm:print-qname/~})" (mapcar #'name attr-nodes))
(format stream " (ns:~{ ~/xqdm:print-ns-node/~})" ns-nodes)
(if assignment
(format stream " ->~/xqdm:print-qname/" (name assignment))
(format stream " ->?"))))
(defMethod print-object ((instance qname-context) stream)
(cond (*print-pretty*
(dotimes (i *context-print-level*) (write-char #\space stream))
(write-char #\[ stream)
(print-content instance stream)
(write-char #\] stream))
(t
(print-unreadable-object (instance stream :type t :identity t)
(print-content instance stream)))))
#|
(defparameter *test*
(sxml-element 'test
"asdf" (sxml-element 'test2 "qwer" "<>")))
(write-node *test* *standard-output*)
(element-bind (name value) entry (print (list name value)))
(element.content (element.content-element *test* 'test2))
(inspect
(with-input-from-string
(stream
"<?xml version='1.0'>
<!DOCTYPE asdf [<!ELEMENT asdf #PCDATA>]>
<asdf attribute1='first' attribute2='second'>
testing&one;
</asdf>")
(|Document-Parser| stream)))
(write-node (top-inspect-form) *standard-output*)
|#
:EOF
\ No newline at end of file
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-query-data-model; -*-
+
+#|
+<DOCUMENTATION>
+ <DESCRIPTION>
+ these classes implement an XML query data model
+ (<a href='WD-query-datamod-20010215%20.html'>XQDM</a>) conformant XML document model.
+ the interface is consistent with the XML infoset
+ (<a href='WD-xml-infoset-20010202.html'>XMLI</a>).
+ this includes support for all node types and an
+ interface which adopt analogous accessor names.
+ <p>
+ where differences exist between the infoset and the query data model the implementation
+ follows XQDM, because the latter
+ <ul>
+ <li>includes the type information,</li>
+ <li>permits a wider range of attribute and element content, whereby
+ the parsing and serialization ensure that the xml standard's constraints
+ are upheld for serial forms.</li>
+ </ul>
+ </p><p>
+ the model varies from the standards in several respects:
+ <ul>
+ <li>the <code>NaR</code> distinguished value is represented with
+ <code>NIL</code>. the context of use is sufficient to distinguish
+ between an empty list and an absent atom.</li>
+ <li>the <code>StringValue</code> <code>valueNode</code> is modeled as a string.
+ as for the remaining types, a class is provided, but the parser produces strings.</li>
+ <li>numerous information items are retained as distinguished nodes
+ rather than masking them as opaque nodes. this includes entities and entity
+ references. the attribute and element node accessors conform to the spec in that they
+ combine content to produce the required value.
+ this makes it easier to represent the literal encoding in a single model.
+ the parser, on the other hand, always expands entity references.
+ </li>
+ <li>cdata and entity markers are not supported. the respective content is
+ instead encapsulated in a reified instance, either directly - as for cdata,
+ or indirectly - as for an entity reference.</li>
+ </ul>
+ </p>
+ </DESCRIPTION>
+ <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
+ href='file://xml/sysdcl.lisp' />
+ <CHRONOLOGY>
+ <DELTA DATE='19990000' AUTHOR='JAA'>
+ this started as a minimal xml document model. to wit, from the original description:
+ <quote>
+ this is an absolutely minimal and nonconforming xml processor.
+ it reads the main document entity, skipping all processing
+ instructions, declarations, and definitions. it returns only the
+ single element in the document. it recognizes entities for <![CDATA[<>&]]>
+ and translates them on input and output. no other entites are
+ supported.
+ </quote></DELTA>
+ <DELTA DATE='19990209' AUTHOR='JAA'>
+ jaa added attribute support
+ </DELTA>
+ <DELTA DATE='20010223' AUTHOR='JAA'>
+ comments, processing instructions and reified attributes
+ </DELTA>
+ <DELTA DATE='20010226' AUTHOR='JAA'>
+ changed names to symbols to support namespaces
+ </DELTA><DELTA DATE='20010301' AUTHOR='JAA'>
+ interface and classes changed to align with the query data model
+ </DELTA>
+ <DELTA DATE='20010308' AUTHOR='JAA'>
+ incorporated accessors and accommodated properties from the infoset.
+ note that
+ <ul>
+ <li>no entity start or end nodes are modeled</li>
+ <li>the URI handling is incomplete.</li></ul></DELTA>
+ <DELTA DATE='20010412' AUTHOR='JAA'>
+ eliminated teh attribute slot from doc-node.</DELTA>
+ <DELTA DATE='20010501' AUTHOR='JAA'>
+ factored out xml-encoding specific classes.</DELTA>
+ <DELTA DATE='20010520'>clone/copy-node to accept overriding initargs</DELTA>
+ <DELTA DATE='20010530'>
+ REF-ENTITY needs to be a NAMED-NODE, in order to bind the target name</DELTA>
+ <DELTA DATE='20010604'>
+ model traversal moved her from xqdm-qnames</DELTA>
+ <DELTA DATE='20010605' AUTHOR='MS'>lispworks conformance</DELTA>
+ <DELTA DATE='20010611'> added |VC: No Duplicate Tokens|</DELTA>
+ <DELTA DATE='20010622'> reader adjustments on null symbol names</DELTA>
+ <DELTA DATE='20010625' AUTHOR='RLF'>fixed arguments in FIRST-MODEL-NAME</DELTA>
+ <DELTA DATE='20010625'>
+ adjustments to print-object for *-model for PCDATA
+ <br />
+ eliminated <code>VALUE</code> speciaization for <code>NS-NODE</code></DELTA>
+ <DELTA DATE='20010626'>eliminated <code>ABSTRACT-NODE</code> from <code>ORDINAL-NODE</code>
+ in order to reduce the implementation of <code>ABSTRACT-ELEM-NODE</code>, which thereby now
+ prescribes <code>ORDINAL</code> and <code>DOCUMENT</code> slots only.
+ changed <code>*CLASS.*</code> parameters to bind classes rather than names
+ </DELTA>
+ <DELTA DATE='20010703'>added attribute initargs to def-type-qname-context</DELTA>
+ <DELTA DATE='20010803'>added def-type.node-validator reader</DELTA>
+ <DELTA DATE='20010816'>additions for schema types</DELTA>
+ <DELTA DATE='20010906'>updated print-object methods for name instances</DELTA>
+ <DELTA DATE='20010914'>ns-nodes for xml and xmlns namespace bindings</DELTA>
+ <DELTA DATE='20011010'>duration-scoped-nodes</DELTA>
+ <DELTA DATE='20011230'>added value alternative to print-object for general entity defs</DELTA>
+ <DELTA DATE='20020116'>names for nameset-tokenizers now accessed with name method</DELTA>
+ <DELTA DATE='20020117'>correction to print-object (def-element-type)</DELTA>
+ <DELTA DATE"'20030320'>conditions consistent with 0.950</DELTA>
+ </CHRONOLOGY>
+ </DOCUMENTATION>
+|#
+
+(in-package "XML-QUERY-DATA-MODEL")
+
+
+;;
+;;
+;; classes
+
+;; abstract
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defClass abstract-class (standard-class) ())
+ (defMethod validate-superclass
+ ((class abstract-class) (superclass standard-class))
+ t)
+ (defMethod validate-superclass
+ ((class standard-class) (superclass abstract-class))
+ t)
+ )
+(defMethod make-instance ((class abstract-class) &key)
+ (xml-error "instantiation precluded for class: ~s." class))
+
+(defClass abstract-node ()
+ ((parent :initform nil :initarg :parent :accessor parent
+ :type (or abstract-node null))
+ (children :initarg :children :accessor children))
+ (:metaclass abstract-class)
+ (:documentation
+ "an <code>ABSTRACT-NODE</code> constitutes the generic form of all instances
+ in a document model and its definition. it comprises the one-many graph
+ relation intrinsic to the document model. it stipulates this structure for
+ all nodes. this even for nodes like <code>DOC-NODE</code> and
+ <code>ATTR-NODE</code>, which maintain a relation to a dominant node, even
+ though they do not have <em>parents</em> according to the DOM
+ specifications."))
+
+(defClass abstract-value-node (abstract-node)
+ ((value :initarg :value))
+ (:metaclass abstract-class)
+ (:documentation
+ "an <code>ABSTRACT-VALUE-NODE</code> encapsulates a datum in a node so that it can be
+ integrated into the document graph. a value which may well be modeled with
+ an atom (eg. a number or a string) still has children, to collect the
+ raw parsed form as its children and to permit complex representations for
+ serialization.
+ the specializations include both direct encapsulations and more complex, annotated values,
+ such as type and entity definitions, element properties, and entity information."))
+
+(defClass named (abstract-node)
+ ((name :initform *null-name* :initarg :name :accessor name
+ :type (or symbol qname-value)))
+ (:metaclass abstract-class))
+
+(defClass named-node (named) () (:metaclass abstract-class))
+(defClass unamed (named) () (:metaclass abstract-class))
+(defClass unamed-node (unamed named-node) () (:metaclass abstract-class))
+(defClass ncnamed (named) () (:metaclass abstract-class))
+(defClass ncnamed-node (ncnamed named-node) () (:metaclass abstract-class))
+
+(defClass typed-node (abstract-node)
+ ((def :initform nil :initarg :def :accessor def
+ :type (or null abstract-def-type)))
+ (:metaclass abstract-class)
+ (:documentation
+ "an abstract class which introduces a definition property for an instance."))
+
+(defClass document-scoped-node ()
+ ((document :initform nil :initarg :document :accessor document))
+ (:metaclass abstract-class)
+ (:documentation
+ "mixin form for classes which exist relative to a document.
+ nb. it makes no provisions for graph relations."))
+
+(defClass duration-scoped-node ()
+ ((ephemeral :initform nil :initarg :ephemeral
+ :reader is-ephemeral :writer (setf ephemeral)
+ :documentation
+ "ranges over T, NIL to specify whether to include the node when serializing."))
+ (:metaclass abstract-class)
+ (:documentation
+ "mixin class to record whether a node should be included in serialized documents.
+ in particular, generated namespaces are not serialized by default."))
+
+
+(defClass ordinal-node ()
+ ((ordinality :initform 0 :initarg :ordinality :type (or fixnum null) :accessor ordinality))
+ (:metaclass abstract-class)
+ (:documentation
+ "a mixin form which binds a position in a global order.
+ this is used to cache the original document order for elements and the local order
+ for references. nb. it makes no provisions for graph relations."))
+
+(defClass document () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+
+(defClass doc-node-interface (document)
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "a mixin marker to indicate that the class implements the minimal document node interface
+ required for serialization:
+ (root children encoding entity-info general-entities notations parameter-entities standalone
+ types version)."))
+
+(defClass elem-node-interface ()
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "a marker mixin to indicate that the class implements the minimal element node interface
+ required for serialization:
+ (name parent children attributes namespaces)."))
+
+(defClass elem-property-node-interface ()
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "a marker mixin to indicate that the class implements the minimal element property interface
+ required for serialization:
+ (name children)."))
+
+
+(defClass entity-information-node (ncnamed-node abstract-value-node)
+ ((uri :initform nil :initarg :uri :accessor uri
+ :documentation
+ "for the document entity, this binds the explicit uri.
+ for external references, it binds the instance form of the system-id.
+ this is generated by resolving the system-id relative to the containing entity.
+ it could also be generated from th epublic id.")
+ (system-id :initform nil :initarg :system-id :accessor system-id)
+ (public-id :initform nil :initarg :public-id :accessor public-id)
+ (encoding :initform nil :initarg :encoding :initarg :encoding-decl
+ :reader encoding)
+ (version :initform nil :initarg :version :initarg :version-info
+ :accessor version)))
+
+(defClass entity-delegate ()
+ ((entity-info :initform nil :initarg :entity-info :writer (setf entity-info)
+ :type (or entity-information-node null)))
+ (:metaclass abstract-class)
+ (:documentation
+ "an abstract root for classes which implement references to external entities "))
+
+(defClass attr-child-node ()
+ ()
+ (:metaclass abstract-class)
+ (:documentation "marker mixin for classes allowed among attributes' children"))
+
+(defClass elem-child-node (document-scoped-node)
+ ()
+ (:metaclass abstract-class)
+ (:documentation "marker mixin for classes allowed among elements' children"))
+
+(defClass doc-child-node (elem-child-node document-scoped-node)
+ ()
+ (:metaclass abstract-class)
+ (:documentation "marker mixin for classes allowed at the document top-level"))
+
+(defClass document-definition-child-object () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+
+(defClass doctype-child-node (document-scoped-node document-definition-child-object)
+ ()
+ (:metaclass abstract-class)
+ (:documentation "marker mixin for classes permitted in the dtd."))
+
+(defClass abstract-elem-property-node (document-scoped-node elem-property-node-interface)
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "a marker mixin for concrete element properties (attributes and ns-nodes)
+ and respective reference nodes."))
+
+(defClass annotation () () (:documentation "added for compatibility with 0.950"))
+(defClass annotation-node (annotation) () (:documentation "added for compatibility with 0.950"))
+(defClass elem-property-node (unamed-node abstract-value-node abstract-elem-property-node
+ typed-node annotation-node)
+ ((value :initform nil))
+ (:metaclass abstract-class)
+ (:documentation
+ "an abstract class for values which are bound to an element as properties or annotations.
+ these include attributes and namespaces."))
+
+(defClass value-node (abstract-value-node)
+ ((value :initform nil))
+ (:metaclass abstract-class)
+ (:documentation
+ "an abstract class for value nodes which provide a default <code>NULL</code> value."))
+
+(defClass named-value-node (ncnamed-node value-node)
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "the abstract root for classes which combine a name and a value property."))
+
+(defClass abstract-def-node (named-node)
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "the abstract class for model nodes which binds the definition of an attribute, element,
+ notation, or entity."))
+
+(defClass abstract-def-type (abstract-def-node)
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "the abstract class of type definitions: attributes, elements, primitive types"))
+
+(defClass abstract-top-level-def-node (abstract-def-node doctype-child-node)
+ ()
+ (:metaclass abstract-class)
+ (:documentation
+ "a marker mixin to indicate that the node is permitted as a top-level definition
+ in a document type definition."))
+
+;; concrete
+
+(defClass doc-node (entity-delegate abstract-node doc-node-interface)
+ ((root :initform nil :initarg :root :accessor root :accessor element
+ :type (or abstract-elem-node null)
+ :documentation
+ "binds the root element of the document.
+ this is also called the <em>document element</em>.
+ it is <em>not</em> the <em>document root</em> - that is the doc-node itself.")
+ (standalone :accessor standalone :initarg :standalone :initarg :sddecl
+ :initform t
+ :documentation
+ "indicates that an external subset is required to properly decode a document.
+ the value is ignored by the parser, but it should be set correctly to enable
+ valid serialization. default is <code>T</code>.")
+ (version :accessor version :initarg :version :initarg :version-info
+ :initform nil)
+ (notations :accessor notations
+ :initform (make-hash-table) :type hash-table)
+ (ids :accessor ids
+ :initform (make-hash-table) :type hash-table)
+ (general-entities :accessor general-entities
+ :initform (make-hash-table) :type hash-table)
+ (parameter-entities :initarg :parameter-entities :accessor parameter-entities
+ :initform (make-hash-table) :type hash-table)
+ (types :accessor types
+ :initform (make-hash-table) :type hash-table)
+ (attributes :initform nil :accessor attributes
+ :type list :documentation
+ "binds attlist definition instances. these are present for documentation
+ purposes only: the effective definitions are integrated in the element
+ type definitions.")
+ (validate :initform nil :initarg :validate :accessor validate?)
+ (namespaces :initform nil :initarg :namespaces :accessor namespaces
+ :documentation
+ "bind the set of namespaces present within the document.")))
+
+(defun document-element (document) (root document))
+(defun (setf document-element) (element document) (setf (root document) element))
+
+
+(defClass document-type-declaration-information-node (entity-information-node document-scoped-node)
+ ())
+
+(defClass abstract-elem-node (ordinal-node doc-child-node elem-node-interface)
+ ((ordinality :initform (when *element-count* (incf *element-count*))))
+ (:metaclass abstract-class)
+ (:documentation
+ "the abstract form for element nodes.
+ extends the <code>elem-node-interface</code> to provide slots for ordinality and document.
+ the graph interface (name parent children attributes namespaces) remains to be implemented
+ by specializers."))
+
+(defClass elem-node (unamed-node typed-node abstract-elem-node)
+ ((children :initform nil :type list)
+ (attributes :initform nil :initarg :attributes :accessor attributes
+ :type list)
+ (namespaces :initform nil :initarg :namespaces :accessor namespaces
+ :type list)
+ (valid)))
+
+(defClass ref-elem-node (ref-node abstract-elem-node) ())
+
+(defClass ext-subset-node (entity-delegate abstract-node)
+ ((children :initform nil :initarg :defs :accessor defs)))
+
+(defClass abstract-attr-node () () (:metaclass abstract-class))
+
+(defClass attribute-node () () (:documentation "added for compatibility with 0.950"))
+(defClass attr-node (elem-property-node abstract-attr-node attribute-node)
+ ()
+ (:metaclass abstract-class))
+
+(defClass normalizing-attr-node (attr-node)
+ ()
+ (:metaclass abstract-class))
+(defClass trimming-attr-node (attr-node)
+ ()
+ (:metaclass abstract-class))
+
+(defClass namespace-declaration () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+
+(defClass abstract-ns-node (namespace-declaration) () (:metaclass abstract-class))
+
+(defClass nsdecl-node () ()
+ (:documentation "for 0.950 compatibility"))
+(defClass ns-node (elem-property-node abstract-ns-node duration-scoped-node nsdecl-node)
+ ((name :initarg :prefix :reader prefix)
+ (children :initform nil)
+ (value :initform nil :initarg :uri :initarg :namespace-name)
+ (namespace :initform nil :initarg :namespace :reader namespace)))
+
+(defClass ref-elem-property-node (ref-node abstract-elem-property-node) ())
+(defClass ref-attr-node (ref-elem-property-node abstract-attr-node) ())
+(defClass ref-ns-node (ref-elem-property-node abstract-ns-node) ())
+
+(defClass decimal-attr-node (attr-node) () )
+(defClass double-attr-node (attr-node) () )
+(defClass entity-attr-node (trimming-attr-node) () )
+(defClass entities-attr-node (attr-node) () )
+(defClass enumerated-attr-node (trimming-attr-node)
+ ()
+ (:metaclass abstract-class))
+(defclass enumeration-attr-node (enumerated-attr-node string-attr-node) () )
+(defClass id-attr-node (trimming-attr-node) () )
+(defClass id-ref-attr-node (trimming-attr-node) () )
+(defClass id-refs-attr-node (attr-node) () )
+(defClass nmtoken-attr-node (trimming-attr-node) () )
+(defClass nmtokens-attr-node (attr-node) () )
+(defClass notation-attr-node (enumerated-attr-node) () )
+(defClass qname-attr-node (attr-node) () )
+(defClass recur-dur-attr-node (attr-node) () )
+(defClass string-attr-node (normalizing-attr-node) () )
+(defClass time-attr-node (attr-node) () )
+(defClass uri-ref-attr-node (attr-node) () )
+
+
+(defClass pi-node (named-node abstract-value-node doc-child-node doctype-child-node)
+ ((value :initform nil)
+ (name :initarg :target :accessor target))
+ (:documentation
+ "a processing instruction binds a </it>target name</it> and a string value.
+ the value should not include the sequence '?>', but that it not enforced."))
+
+(defClass comment-node (abstract-value-node doc-child-node doctype-child-node)
+ ())
+
+(defClass character-data-node (abstract-value-node doc-child-node)
+ ())
+
+(defClass info-item-node (abstract-node)
+ ())
+
+(defClass ref-node (abstract-value-node ordinal-node)
+ ())
+
+(defClass binary-value (value-node elem-child-node attr-child-node) ())
+(defClass bool-value (value-node elem-child-node attr-child-node) ())
+(defClass decimal-value (number-value) ())
+(defClass double-value (number-value) ())
+(defClass entity-value (value-node attr-child-node) ())
+(defClass float-value (number-value) ())
+(defClass function-value (named-value-node)
+ ((value :initarg :expression :reader expression)))
+(defClass id-value (value-node attr-child-node) ())
+(defClass id-ref-value (value-node attr-child-node) ())
+(defClass notation-value (value-node attr-child-node) ())
+(defClass number-value (value-node elem-child-node attr-child-node) ()
+ (:metaclass abstract-class))
+(defClass qname-value (named-value-node attr-child-node)
+ ((name :initarg :local-part :reader local-part)
+ (value :initform nil :reader qname
+ :documentation "binds the universal name symbol")
+ (prefix :initform nil :initarg :prefix :reader prefix)
+ (uri :initform nil :initarg :uri :reader uri)
+ (namespace :initform nil :initarg :namespace :reader namespace)))
+(defClass recur-dur-value (value-node elem-child-node attr-child-node) ())
+(defClass string-value (value-node elem-child-node attr-child-node) ())
+(defClass time-dur-value (value-node elem-child-node attr-child-node) ())
+(defClass uri-ref-value (named-value-node elem-child-node attr-child-node) ()
+ (:documentation "wrap an uri instance with an appropriately typed node."))
+
+
+(defClass qname-context-delegate ()
+ ((qname-context :accessor qname-context :initform nil
+ :documentation "binds a context to collect and resolve qualified names."))
+ (:metaclass abstract-class)
+ (:documentation
+ "augments definitions which collect qualified names."))
+
+(defClass element-definition () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+(defClass element-type-definition () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+(defClass doctype-element-definition (element-definition element-type-definition) ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+
+(defClass def-elem-type (doctype-element-definition
+ unamed-node abstract-def-type abstract-top-level-def-node
+ qname-context-delegate abstract-value-node
+ )
+ ((value :initform nil :reader node-validator
+ :documentation "binds the compiled validator")
+ (children :initarg :model :accessor model :initform nil
+ :documentation "binds the bnf content model")
+ ;; (type :initarg :type :reader type)
+ (node-class :initform nil :initarg :node-class
+ :documentation "binds the class used to instantiate element nodes of this type")
+ (properties :initform nil :initarg :properties :accessor properties)
+ (props-required :initform nil
+ :documentation
+ "a bit-mirror for definitions in properties where =1 implies required")
+ (props-defaulted :initform nil
+ :documentation
+ "a bit-mirror for definitions in properties where =1 implies default")))
+
+(defun direct-annotation-model (definition) "0-950" (properties definition))
+(defun (setf direct-annotation-model) (model definition) "0-950" (setf (properties definition) model))
+(defun annotation-model (definition) "0-950" (properties definition))
+(defun content-model (definition) "0-950" (model definition))
+
+(defClass doctype-attlist-definition () () (:documentation "0.950"))
+(defClass def-attr (doctype-attlist-definition
+ abstract-top-level-def-node unamed-node qname-context-delegate
+ duration-scoped-node)
+ ((children :initarg :attributes :accessor attributes :initform nil))
+ (:documentation
+ "a <code>DEF-ATTR</code> collects a set of attribute definitions for a given
+ element type context."))
+
+(defClass annotation-definition () () (:documentation "0.950"))
+(defClass doctype-annotation-definition (annotation-definition) () (:documentation "0.950"))
+(defClass def-elem-property-type (unamed-node abstract-def-type abstract-def-node
+ duration-scoped-node
+ doctype-annotation-definition)
+ ((children :initform nil :initarg :enumeration :reader enumeration)
+ (stipulation :initarg :stipulation :initform nil :reader stipulation)
+ (prototype :initarg :prototype :initform nil :reader prototype))
+ (:documentation
+ "for use in the element definition."))
+
+(defClass def-notation (abstract-top-level-def-node entity-information-node)
+ ())
+
+(defClass def-entity (ncnamed-node abstract-top-level-def-node abstract-value-node)
+ ((value :initform nil)
+ (extent :initform nil :initarg :extent :reader extent
+ :type (member :static :temporary nil))
+ (maybe-markup-text :initform :unknown))
+ (:metaclass abstract-class))
+
+(defClass general-entity-definition () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+(defClass def-general-entity (def-entity general-entity-definition) () (:metaclass abstract-class))
+
+(defClass parameter-entity-definition () ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+(defClass def-parameter-entity (def-entity parameter-entity-definition) () (:metaclass abstract-class))
+(defClass def-internal-entity (def-entity) () (:metaclass abstract-class))
+(defClass def-external-entity (entity-delegate def-entity)
+ ((children :initform nil))
+ (:metaclass abstract-class))
+(defClass def-internal-general-entity (def-internal-entity def-general-entity)
+ ())
+(defClass def-external-general-entity (def-external-entity def-general-entity)
+ ((notation :initform nil :initarg :notation :reader notation)))
+(defClass def-internal-parameter-entity (def-internal-entity def-parameter-entity) ())
+(defClass def-external-parameter-entity (def-external-entity def-parameter-entity)
+ ((children :initform nil)))
+
+(defClass type-definition (named) ()
+ (:documentation "added for compatibility with 0.950 conditions"))
+
+(defClass ref-entity (ref-node named-node attr-child-node)
+ ((expand :initform nil :initarg :expand :accessor expand
+ :documentation "specifies whether to expand the entity when encoding."))
+ (:metaclass abstract-class))
+(defClass ref-general-entity (ref-entity elem-child-node) () )
+(defClass ref-parameter-entity (ref-entity doctype-child-node) () )
+(defClass ref-character-entity (ref-entity elem-child-node) ())
+
+(defClass conditional-section (ref-parameter-entity)
+ ()
+ (:documentation
+ "a <code>CONDITIONAL-SECTION</code> specializes the behaviour of a pe-reference
+ and serves as the container for conditional declarations, the presence of which
+ depend on the respective entites value.
+ it is produced by parsing external declaration subsets with
+ pe expansion disabled, and may also be generated programmatically."))
+
+(defClass external-parsed-entity (entity-delegate ref-general-entity)
+ ()
+ (:documentation
+ "an <code>EXTERNAL_PARSED-ENTITY</code> acts as a container for an external parsed general
+ entity. it binds the content sequence and the encoding. it is used to enforce the
+ structural constraints on the entities content."))
+
+;;
+;;
+;; model classes
+
+(defClass content-model () ())
+(defClass |content-model| (bnfp::bnf-phrase-definition content-model) ())
+(defClass |\|-content| (bnfp::bnf-alternative content-list) () )
+(defClass content-occurrence () ())
+(defClass |?-content| (bnfp::bnf-opt-expr content-occurrence) () )
+(defClass |*-content| (bnfp::bnf-rep-expr content-occurrence) () )
+(defClass |bounded-content| (bnfp::bnf-qexpr content-occurrence)
+ ((min :initarg :min :initform nil)
+ (max :initarg :max :initform nil)) )
+(defClass |MIXED-content| (|*-content|) () )
+(defClass |+-content| (bnfp::bnf-plus-expr content-occurrence) () )
+(defClass |content| (bnfp::bnf-one-expr content-occurrence) () )
+(defClass content-list () ())
+(defClass |,-content| (bnfp::bnf-group content-list) () )
+(defClass content-name () ())
+(defClass |content-name| (bnfp::bnf-phrase-symbol content-name) () )
+(defClass type-name () ())
+(defClass |type-name| (bnfp::bnf-nonterminal-symbol type-name) () )
+(defClass mixed-atn (bnfp::atn) ())
+(defClass element-atn (bnfp::atn) ())
+
+(defMethod name ((instance |content-name|)) (bnfp::bnf-name instance))
+(defMethod (setf name) (name (instance |content-name|)) (setf (bnfp::bnf-name instance) name))
+(defMethod name ((instance |type-name|)) (bnfp::bnf-name instance))
+(defMethod (setf name) (name (instance |type-name|)) (setf (bnfp::bnf-name instance) name))
+(defMethod name ((instance |content-model|)) (name (bnfp::bnf-lhs instance)))
+(defMethod nonterminal ((instance |content-model|)) (bnfp::bnf-lhs instance))
+(defMethod grammar ((instance |content-model|)) (bnfp::bnf-rhs instance))
+(defun expressions (x) (bnfp::bnf-expressions x))
+(defmethod expression ((x content-occurrence)) (bnfp::bnf-expression x))
+
+(defMethod print-object ((object |content-name|) stream &aux name)
+ (setf name (and *print-pretty* (bnfp::bnf-name object)))
+ ;; only the special case of PCDATA with other elements gets here
+ ;; ANY and EMPTY never get here -- see below
+ (cond ((eq name *mixed-name*) (princ "#PCDATA" stream))
+ (t (call-next-method))))
+
+(defMethod print-object ((object |*-content|) stream &aux expr name)
+ (setf name (when (and *print-pretty*
+ (typep (setf expr (bnfp::bnf-expression object)) '|content-name|))
+ (bnfp::bnf-name expr)))
+ (cond ((eq name *wild-name*) (princ "ANY" stream))
+ ((eq name *empty-name*) (princ "EMPTY" stream))
+ ((eq name *mixed-name*) (princ "(#PCDATA)" stream))
+ (t (call-next-method))))
+
+;;
+;;
+;; walking definition components
+
+(defGeneric walk-model-names (particle function)
+ ;; type declaration data
+ (:method ((context def-elem-type) (function t))
+ (setf (name context) (funcall function (name context)))
+ (walk-model-names (properties context) function)
+ (walk-model-names (model context) function))
+ ;; generic expression data
+ (:method ((context t) (function t)) nil)
+ (:method ((decls list) (function t))
+ (dolist (decl decls) (walk-model-names decl function)))
+ ;; attribute declaration data
+ (:method ((context def-elem-property-type) (function t))
+ (with-slots (prototype) context
+ (setf (name context) (funcall function (name context)))
+ (when prototype
+ (setf (name prototype) (funcall function (name prototype))))))
+ (:method ((context elem-property-node) (function t))
+ (with-slots (def) context
+ (setf (name context) (funcall function (name context)))
+ (when def (setf (name def) (funcall function (name def))))))
+ ;; content model data
+ (:method ((context |content-model|) (function t))
+ (walk-model-names (bnfp::bnf-lhs context) function)
+ (walk-model-names (bnfp::bnf-rhs context) function))
+ (:method ((context |\|-content|) (function t))
+ (walk-model-names (bnfp::bnf-expressions context) function))
+ (:method ((context |?-content|) (function t))
+ (walk-model-names (bnfp::bnf-expression context) function))
+ (:method ((context |*-content|) (function t))
+ (walk-model-names (bnfp::bnf-expression context) function))
+ (:method ((context |+-content|) (function t))
+ (walk-model-names (bnfp::bnf-expression context) function))
+ (:method ((context |content|) (function t))
+ (walk-model-names (bnfp::bnf-expression context) function))
+ (:method ((context |,-content|) (function t))
+ (walk-model-names (bnfp::bnf-expressions context) function))
+ (:method ((context |content-name|) (function t))
+ (setf (bnfp::bnf-name context) (funcall function (bnfp::bnf-name context))))
+ (:method ((context |type-name|) (function t))
+ (setf (bnfp::bnf-name context) (funcall function (bnfp::bnf-name context)))))
+
+(defMethod collect-model-names ((model |content-model|) &aux names is-mixed (model-name (name model)))
+ (walk-model-names model
+ #'(lambda (name)
+ (cond ((or (eq name *empty-name*) (eq name *wild-name*))
+ (push name names)
+ name)
+ ((eq name *mixed-name*) (setf is-mixed t) name)
+ (t (push name names) name))))
+ (when (and (validate? *document*) is-mixed)
+ (mapl #'(lambda (rest &aux (name (first rest)))
+ (when (find name (rest rest)
+ :test #'(lambda (n1 n2)
+ (and (bnfp::name= n1 n2)
+ (not (eq n1 model-name)) (not (eq n2 model-name)))))
+ (|VC: No Duplicate Types| :context model :name (first rest))))
+ names))
+ names)
+
+(defMethod collect-model-names ((model bnfp::bnf-expr) &aux names)
+ (walk-model-names model
+ #'(lambda (name)
+ (cond ((or (eq name *empty-name*) (eq name *wild-name*))
+ (pushnew name names)
+ name)
+ ((eq name *mixed-name*) name)
+ (t (pushnew name names) name))))
+ (nreverse names))
+
+(defGeneric first-model-name (model)
+ (:method ((model |content-model|))
+ (first-model-name (bnfp::bnf-rhs model)))
+ (:method ((model t))
+ (walk-model-names model #'(lambda (name) (return-from first-model-name name)))))
+
+
+;;
+;;
+;; classes for qualified name resolution
+
+(defClass qname-context ()
+ ((name :initarg :name :reader name)
+ (def :initform nil :initarg :def :reader def :reader definition)
+ (pass-id :initform nil :accessor pass-id))
+ (:documentation
+ "a <code>QNAME-CONTEXT</code> collects the uninterned qnames which are governed by a
+ given declaration. it is used while reading the document type definition. at the point of
+ appearance of each declaration a new one is created."))
+
+(defClass def-type-qname-context (qname-context)
+ ((parents :initform nil :accessor parents)
+ (children :initform nil :accessor children)
+ (content-names :initarg :content-names :reader content-names)
+ (attr-nodes :initform nil :initarg :attr-nodes :accessor attr-nodes
+ :initarg :attributes :accessor attributes)
+ (ns-nodes :initform nil :initarg :ns-nodes :accessor ns-nodes
+ :initarg :nsdecl-nodes :accessor nsdecl-nodes
+ :initarg :namespace-declarations :accessor namespace-declarations)
+ (successors :initform nil
+ :documentation
+ "binds the conceivable successors based on the literal qualified names.")
+ (ns-cache :initform nil :accessor ns-cache
+ :documentation "bind results from searching parents"))
+ (:documentation
+ "a <code>def-type-QNAME-CONTEXT</code> collects the qualified names which contribute to
+ an individual element declaration. it is created with the names from the element
+ declaration proper and augmented with those from related attribute list declarations.
+ in the process of resolving qualified names to universal names, relations among element
+ contexts are established to simulate the visibility of prefix/namespace bindings
+ as specified for the document entity."))
+
+(defClass def-attr-qname-context (qname-context)
+ ((name :writer (setf name))
+ (attr-nodes :initform nil :initarg :attr-nodes :accessor attr-nodes
+ :initarg :attributes :accessor attributes)
+ (ns-nodes :initform nil :initarg :ns-nodes :accessor ns-nodes
+ :initarg :nsdecl-nodes :accessor nsdecl-nodes
+ :initarg :namespace-declarations :accessor namespace-declarations)
+ (assignment :initform nil :accessor assignment))
+ (:documentation
+ "a <code>DEF-ATTR-QNAME-CONTEXT</code> collects the qualified names which contribute
+ to attribute declarations for an element. note that the namespace nodes can be neglected
+ as the 'xmlns' prefix/namespace binding is static.
+ in the process of resolving qualified names to universal names, each attribute context
+ is merged into a element context."))
+
+(defGeneric walk-model-nodes (particle function)
+ (:documentation
+ "walk the model tree and apply the function to each node. for 0.950")
+ (:method ((context element-definition) (function t))
+ (funcall function context)
+ (walk-model-nodes (annotation-model context) function)
+ (walk-model-nodes (content-model context) function))
+ (:method ((context t) (function t)) nil)
+ (:method ((decls list) (function t))
+ (dolist (decl decls) (walk-model-nodes decl function)))
+ (:method ((node ext-subset-node) (function t))
+ (walk-model-nodes (children node) function))
+ (:method ((context annotation-definition) (function t))
+ (with-accessors ((prototype prototype)) context
+ (funcall function context)
+ (when prototype
+ (funcall function prototype))))
+ (:method ((context annotation) (function t))
+ (with-accessors ((definition definition)) context
+ (funcall function context)
+ (when definition(funcall function definition))))
+ (:method ((context def-type-qname-context) (function t))
+ (funcall function context)
+ (mapcar #'(lambda (def) (walk-model-nodes def function)) (namespace-declarations context))
+ (let ((*default-namespace-is-visible* nil))
+ (mapcar #'(lambda (def) (walk-model-names def function)) (attributes context)))
+ (walk-model-nodes (def context) function))
+ ;; content model data
+ (:method ((context content-model) (function t))
+ (walk-model-nodes (nonterminal context) function)
+ (walk-model-nodes (grammar context) function))
+ (:method ((context content-list) (function t))
+ (walk-model-nodes (expressions context) function))
+ (:method ((context content-occurrence) (function t))
+ (walk-model-nodes (expression context) function))
+ (:method ((context content-name) (function t))
+ (funcall function context))
+ (:method ((context type-name) (function t))
+ (funcall function (name context))))
+
+;;
+;;
+;; types and constructors
+;; nb. no constructors defined for the abstract classes...
+
+(defMacro defClassConstructor (name)
+ `(defun ,(intern (concatenate 'string "MAKE-" (string name)))
+ (&rest initargs)
+ (declare (dynamic-extent initargs))
+ (apply #'make-instance
+ ,(intern (concatenate 'string "*CLASS." (string name) "*"))
+ initargs)))
+
+(defMacro defClassConstructors (&rest names)
+ `(progn
+ ,@(mapcar #'(lambda (name)
+ `(defParameter ,(intern (concatenate 'string "*CLASS." (string name) "*"))
+ (find-class ',name)))
+ names)
+ ,@(mapcar #'(lambda (name) `(defClassConstructor ,name)) names)))
+
+
+(defMacro defTypePredicate (name)
+ `(defun ,(intern (concatenate 'string "IS-" (string name))) (x)
+ (typep x ',name)))
+
+(defvar *export-output* )
+(defMacro defTypePredicates (&rest names)
+ (when (boundp '*export-output*)
+ (mapcar #'(lambda (names)
+ (format *export-output* "~%~{~s~^ ~}" names))
+ (sort (mapcar #'(lambda (name)
+ (list* (string name)
+ (concatenate 'string "IS-" (string name))
+ (unless (string= "ABSTRACT" name :end2 (min (length (string name)) 8))
+ (list (concatenate 'string "*CLASS." (string name) "*")
+ (concatenate 'string "MAKE-" (string name))))))
+ names)
+ #'string< :key #'first)))
+ `(progn ,@(mapcar #'(lambda (name)
+ `(defTypePredicate ,name)) names)))
+
+(defClassConstructors
+ doc-node elem-node ns-node ext-subset-node
+ decimal-attr-node double-attr-node entity-attr-node entities-attr-node
+ enumeration-attr-node id-attr-node id-ref-attr-node id-refs-attr-node
+ nmtoken-attr-node nmtokens-attr-node notation-attr-node
+ qname-attr-node recur-dur-attr-node string-attr-node time-attr-node
+ uri-ref-attr-node
+ pi-node comment-node info-item-node character-data-node
+ document-type-declaration-information-node entity-information-node
+ string-value bool-value float-value double-value decimal-value
+ time-dur-value recur-dur-value binary-value uri-ref-value id-value id-ref-value
+ qname-value entity-value notation-value function-value
+ def-attr def-elem-property-type def-elem-type def-notation
+ def-internal-general-entity def-external-general-entity
+ ref-node
+ def-internal-parameter-entity def-external-parameter-entity
+ ref-parameter-entity ref-general-entity ref-character-entity
+ conditional-section external-parsed-entity)
+
+(defTypePredicates
+ doc-node abstract-elem-node elem-node ext-subset-node ordinal-node
+ elem-property-node abstract-elem-property-node
+ abstract-attr-node attr-node abstract-ns-node ns-node
+ def-elem-property-type
+ elem-child-node attr-child-node doctype-child-node doc-child-node
+ decimal-attr-node double-attr-node entity-attr-node entities-attr-node
+ enumeration-attr-node id-attr-node id-ref-attr-node id-refs-attr-node
+ nmtoken-attr-node nmtokens-attr-node notation-attr-node
+ qname-attr-node recur-dur-attr-node string-attr-node time-attr-node
+ uri-ref-attr-node
+ pi-node comment-node info-item-node character-data-node
+ document-type-declaration-information-node entity-information-node
+ value-node string-value bool-value number-value float-value double-value decimal-value
+ time-dur-value recur-dur-value binary-value uri-ref-value id-value id-ref-value
+ qname-value entity-value notation-value function-value
+ abstract-def-node abstract-top-level-def-node abstract-def-type
+ def-attr def-elem-type def-notation def-entity
+ def-internal-entity def-external-entity def-parameter-entity def-general-entity
+ def-internal-general-entity def-external-general-entity
+ def-internal-parameter-entity def-external-parameter-entity
+ ref-node ref-entity
+ ref-parameter-entity ref-general-entity ref-character-entity
+ conditional-section external-parsed-entity
+ qname-context)
+
+(defun element-p (x) (is-abstract-elem-node x))
+(defun id-attr-node-p (x) (is-id-attr-node x))
+(defun nsdecl-node-p (x) (is-ns-node x))
+;;
+;;
+;; supplementary accessors
+
+(defMethod value ((node value-node))
+ (with-slots (children value) node
+ (or value (setf value (value-string children)))))
+
+(defMethod parent ((node string)) nil)
+(defMethod children ((node string)) nil)
+
+(defGeneric validate? (node)
+ (:documentation "bound directly to document nodes. other nodes resolve relative to the container, or yield nil.")
+ (:method ((node document-scoped-node)) (validate? (document node)))
+ (:method ((node null)) nil)
+ (:method ((node t)) (warn "validation not defined for node: ~s." node) nil))
+(defun validate-p (x) (validate? x))
+
+#|
+;; the value generators for entites are only marginally useful.
+;; the replacement mechanism uses the input sequence stored in the child slot
+;; rather than the string which would have been produced here
+
+(defMethod value ((node ref-parameter-entity))
+ (with-slots (value name) node
+ (or value (setf value (parameter-entity-value name)))))
+
+(defMethod value ((node ref-general-entity))
+ (with-slots (value name) node
+ (or value (setf value (general-entity-value name)))))
+
+(defMethod value ((node def-internal-entity))
+ (with-slots (children value) node
+ (or value (setf value (value-string children)))))
+
+(defMethod value ((node def-external-entity) &aux (uri (uri node)))
+ (with-slots (children value) node
+ (if value
+ value
+ (setf children nil
+ value (when uri
+ (read-external-entity uri))))))
+
+|#
+
+(defMethod value ((node entities-attr-node))
+ (with-slots (children value document) node
+ (cond (value)
+ (children
+ (setf value (mapcar #'(lambda (name &aux entity)
+ (unless (is-ncname name)
+ (|VC: ID| :name (name node) :value value
+ :detail "not an NCName"))
+ (setf name (intern-name name *null-namespace*))
+ (when document
+ (when (setf entity (find-def-general-entity name document))
+ (unless (and (is-def-external-general-entity entity)
+ (notation entity))
+ (|VC: Entity Name| :name name))))
+ name)
+ (split-string (value-string children)
+ #(#\space #\return #\linefeed #\tab))))))))
+
+(defMethod value ((node entity-attr-node) &aux entity)
+ (with-slots (children value document) node
+ (cond (value)
+ (t
+ (unless (is-ncname (setf value
+ (normalize-value node (value-string children))))
+ (|VC: Entity Name| :context (name node) :name value
+ :detail "not an NCName"))
+ (setf value (intern-name value *null-namespace*))
+ (when document
+ (when (setf entity (find-def-general-entity value document))
+ (unless (and (is-def-external-general-entity entity)
+ (notation entity))
+ (|VC: Entity Name|
+ :context (name node) :name value
+ :detail "must name an unparsed entity"))))))))
+
+(defMethod value ((node id-attr-node))
+ (with-slots (children value) node
+ (cond (value)
+ (children
+ (unless (is-ncname (setf value
+ (normalize-value node (value-string children))))
+ (|VC: ID| :name (name node) :value value
+ :detail "not an NCName"))
+ (setf value (intern-name value *null-namespace*))))))
+
+(defMethod value ((node id-ref-attr-node))
+ (with-slots (children value) node
+ (cond (value)
+ (children
+ (unless (is-ncname (setf value
+ (normalize-value node (value-string children))))
+ (|VC: ID| :name (name node) :value value
+ :detail "not an NCName"))
+ (setf value (intern-name value *null-namespace*))))))
+
+(defMethod value ((node id-refs-attr-node))
+ (with-slots (children value) node
+ (cond (value)
+ (children
+ (setf value (mapcar #'(lambda (name)
+ (unless (is-ncname name)
+ (|VC: ID| :name (name node) :value value
+ :detail "not an NCName"))
+ (intern-name name *null-namespace*))
+ (split-string (value-string children)
+ #(#\space #\return #\linefeed #\tab))))))))
+
+(defMethod value ((node nmtoken-attr-node))
+ (with-slots (children value) node
+ (cond (value)
+ (children
+ (unless (is-namechardata (setf value
+ (normalize-value node (value-string children))))
+ (|VC: Name Token| :name (name node) :value value
+ :detail "not a Name"))
+ (setf value (intern-name value *null-namespace*))))))
+
+
+(defMethod value ((node nmtokens-attr-node))
+ (with-slots (children value) node
+ (cond (value)
+ (children
+ (setf value (mapcar #'(lambda (name)
+ (unless (is-namechardata name)
+ (|VC: Name Token|
+ :name (name node) :value name
+ :detail "not an Name"))
+ (intern-name name *null-namespace*))
+ (split-string (value-string children)
+ #(#\space #\return #\linefeed #\tab))))))))
+
+
+(defMethod value ((node notation-attr-node))
+ (with-slots (children value def) node
+ (cond (value)
+ (children
+ (setf value (normalize-value node (value-string children)))
+ (unless (is-namechardata value)
+ (|VC: Name Token| :name (name node) :value value
+ :detail "not an Name"))
+ (setf value (intern-name value *null-namespace*))
+ (when def
+ (unless (find value (enumeration def))
+ (|VC: Notation Attributes| :name value))))
+ (t
+ (|VC: Name Token| :name (name node) :value value
+ :detail "not an Name")))))
+
+(defMethod value ((node enumeration-attr-node))
+ (with-slots (children value def) node
+ (cond (value)
+ (children
+ (call-next-method)
+ (when def
+ (unless (find value (enumeration def) :test #'string=)
+ (|VC: Enumeration| :name value)))))))
+
+(defMethod value ((node string-attr-node))
+ (with-slots (children value) node
+ (if value value
+ (setf value (normalize-value node (value-string children))))))
+
+(defmethod (setf value) ((new-value string) (node string-attr-node))
+ (with-slots (children value) node
+ (setf children (list new-value)
+ value new-value)))
+
+(defMethod value ((node ns-node))
+ (with-slots (children value) node
+ (if value value
+ (setf value (normalize-value node (value-string children))))))
+
+(defMethod uri ((node ns-node))
+ (value node))
+
+(defMethod namespace-name ((node ns-node))
+ (value node))
+
+(defMethod value ((node pi-node))
+ (with-slots (value children) node
+ (or value (setf value (or (first children) "")))))
+
+(defMethod (setf value) ((new-value string) (node pi-node))
+ (with-slots (value children) node
+ (setf value new-value
+ children (list new-value))))
+
+(defMethod (setf value) ((new-value t) (node pi-node))
+ (assert (typep new-value 'string)))
+
+(defMethod value ((node uri-ref-value))
+ (with-slots (value children) node
+ (if value value
+ (setf value (make-uri (string-trim #(#\space) (value-string children)) *xml-base*)))))
+
+;;
+;; normalizing reduces all space to a single character, trimming, in addition,
+;; removes initial and trailing space
+;; nb. in order to keep the model independent of the respective parser, a simple subsequence
+;; is generated and no attempt is made to return string buffers, as the only xml parser uses them.
+
+(defGeneric normalize-value (node value)
+ (:documentation
+ "value normalization is specified by the XML standard.
+ it is performed when a value is generated from children, which is the case
+ when a node is generated by the parser.")
+ (:method ((node attr-node) (value t)) value))
+
+(defMethod normalize-value ((node normalizing-attr-node) (value string)
+ &aux (to 0) (from 0) (end (length value)) char space?)
+ (loop (when (>= from end) (return))
+ (cond ((xml-space? (setf char (schar value from)))
+ (setf (schar value to) #\space)
+ (unless space?
+ (incf to)
+ (setf space? t)))
+ (t
+ (setf (schar value to) char)
+ (setf space? nil)
+ (incf to)))
+ (incf from))
+ (cond ((= to end) value)
+ (t (subseq value 0 to))))
+
+(defun normalize-and-trim-string (value &aux (to 0) (from 0) (end (length value)) char space?)
+ (loop (when (>= from end) (return))
+ (cond ((xml-space? (setf char (schar value from)))
+ (setf (schar value to) #\space)
+ (when (and (not space?) (> to 0))
+ (incf to)
+ (setf space? t)))
+ (t
+ (setf (schar value to) char)
+ (setf space? nil)
+ (incf to)))
+ (incf from))
+ (when (and (> to 0) (xml-space? (schar value (1- to))))
+ (decf to))
+ (cond ((= to end) value)
+ (t (subseq value 0 to))))
+
+(defMethod normalize-value ((node trimming-attr-node) (value string))
+ (normalize-and-trim-string value))
+
+(defMethod normalize-value ((node ns-node) (value string))
+ (normalize-and-trim-string value))
+
+
+;(normalize-value (allocate-instance (find-class 'string-attr-node)) " d a ")
+;(normalize-value (allocate-instance (find-class 'nmtoken-attr-node)) " this-gets-normalized ")
+
+
+(defMethod (setf parent) :after
+ ((parent elem-node) (instance attr-node))
+ ;; generate the value in order to enforce constraints. this is deferred until
+ ;; the attribute is bound to an element in order to use the context when generating
+ ;; interned values.
+ (when (validate? instance)
+ (value instance)))
+
+(defMethod (setf parent) :after
+ ((parent elem-node) (instance id-attr-node) &aux (id (value instance)))
+ ;; bind the id within the document
+ (with-slots (document) instance
+ (when (setf document (document parent))
+ (when (gethash id (ids document))
+ (|VC: ID| :name (name instance) :value id :detail "not unique"))
+ (setf (gethash id (ids document)) instance))))
+
+;;
+;;
+;; encapsulated children are expendable for attribute/ns nodes and for value
+;; nodes themselves.
+;; children generated as parse artifacts or may be asserted for serialization.
+;; the value slot dominates and modifies the children implicitly.
+
+(defMethod (setf value) ((new-value string) (node value-node))
+ (with-slots (children value) node
+ (setf value new-value)
+ (setf children (list new-value))))
+
+(defMethod (setf value) ((new-value value-node) (node value-node))
+ (with-slots (children value) node
+ (setf value new-value)
+ (setf children (list (value-string new-value)))))
+
+;;
+;;
+;; entity information delegation
+
+(defMethod entity-info ((node entity-delegate))
+ (with-slots (entity-info) node
+ (or entity-info
+ (setf entity-info (make-instance 'entity-information-node)))))
+
+(defMethod name ((node doc-node))
+ (with-slots (entity-info) node
+ (when entity-info (name entity-info))))
+(defMethod (setf name) (value (node doc-node))
+ (setf (name (entity-info node)) value))
+
+(defMethod uri ((node entity-delegate))
+ (with-slots (entity-info) node
+ (when entity-info (uri entity-info))))
+(defMethod (setf uri) (value (node entity-delegate))
+ (setf (uri (entity-info node)) value))
+
+(defMethod system-id ((node entity-delegate))
+ (with-slots (entity-info) node
+ (when entity-info (system-id entity-info))))
+(defMethod (setf system-id) (value (node entity-delegate))
+ (setf (system-id (entity-info node)) value))
+(defMethod (setf system-id) :after ((value t) (node entity-information-node))
+ (with-slots (uri system-id public-id) node
+ (setf uri (resolve-entity-identifiers public-id system-id *xml-base*))))
+
+(defMethod public-id ((node entity-delegate))
+ (with-slots (entity-info) node
+ (when entity-info (public-id entity-info))))
+(defMethod (setf public-id) (value (node entity-delegate))
+ (setf (public-id (entity-info node)) value))
+(defMethod (setf public-id) :after ((value t) (node entity-information-node))
+ (with-slots (uri system-id public-id) node
+ (setf uri (resolve-entity-identifiers public-id system-id *xml-base*))))
+
+(defMethod encoding ((node entity-delegate))
+ (with-slots (entity-info) node
+ (when entity-info (encoding entity-info))))
+(defMethod (setf encoding) (value (node entity-delegate))
+ (setf (encoding (entity-info node)) value))
+
+(defmethod encoding ((node document-scoped-node))
+ (encoding (document node)))
+
+(defgeneric (setf encoding) (encoding entity-information-node)
+ (:method ((encoding string) (node entity-information-node) &aux canonical-encoding)
+ (cond
+ ((setf canonical-encoding (canonical-encoding encoding))
+ (setf (slot-value node 'encoding) canonical-encoding))
+ (t
+ (error "illegal encoding: ~s." encoding))))
+ (:method ((encoding symbol) (node entity-information-node) &aux canonical-encoding)
+ (cond
+ ((setf canonical-encoding (canonical-encoding encoding))
+ (setf (slot-value node 'encoding) canonical-encoding))
+ (t
+ (error "illegal encoding: ~s." encoding)))))
+
+(defMethod version ((node entity-delegate))
+ (with-slots (entity-info) node
+ (when entity-info (version entity-info))))
+(defMethod (setf version) (value (node entity-delegate))
+ (setf (version (entity-info node)) value))
+
+
+;;
+;;
+;; reference node access delegation
+
+(defMacro defDelegateMethod (name ((instance class)) slot)
+ `(progn (defMethod ,name ((,instance ,class))
+ (with-slots (,slot) ,instance (,name ,slot)))
+ (defMethod (setf ,name) (new-value (,instance ,class))
+ (with-slots (,slot) ,instance (setf (,name ,slot) new-value)))))
+
+(defDelegateMethod children ((node ref-elem-node)) value)
+(defDelegateMethod name ((node ref-elem-node)) value)
+(defDelegateMethod attributes ((node ref-elem-node)) value)
+(defDelegateMethod def ((node ref-elem-node)) value)
+(defDelegateMethod namespaces ((node ref-elem-node)) value)
+(defDelegateMethod valid ((node ref-elem-node)) value)
+
+(defDelegateMethod children ((node ref-elem-property-node)) value)
+(defDelegateMethod name ((node ref-elem-property-node)) value)
+(defDelegateMethod def ((node ref-elem-property-node)) value)
+(defDelegateMethod value ((node ref-elem-property-node)) value)
+#+sbcl(make-instance 'ref-ns-node)
+(defDelegateMethod namespace ((node ref-ns-node)) value)
+
+;;
+;;
+;; node cloning. for attributes
+
+(defMethod clone-node
+ ((instance abstract-node) &rest initargs &aux new)
+ (declare (dynamic-extent initargs))
+ (setf new (allocate-instance (class-of instance)))
+ ;; initialize overriding slot values.
+ ;; do this first, to inhibit side-effects from copying
+ (when initargs (apply #'shared-initialize new nil initargs))
+ (copy-node instance new)
+ new)
+
+(defMethod clone-node ((instance string) &key) instance)
+
+(defMethod clone-node ((nodes list) &rest initargs)
+ (mapcar #'(lambda (x) (apply #'clone-node x initargs)) nodes))
+
+
+(defGeneric copy-node (from to)
+ (:documentation
+ "copy slot values from one node to another.
+ slots with bound values are left unchanged.")
+ (:method-combination progn :most-specific-last)
+ (:method progn ((from abstract-node) (to abstract-node))
+ (unless (slot-boundp to 'parent)
+ (setf (slot-value to 'parent) nil))
+ (unless (slot-boundp to 'children)
+ (setf (slot-value to 'children) (clone-node (children from)))))
+ (:method progn ((from typed-node) (to typed-node))
+ (unless (slot-boundp to 'def)
+ (setf (slot-value to 'def) (slot-value from 'def))))
+ (:method progn ((from named-node) (to named-node))
+ (unless (slot-boundp to 'name)
+ (setf (slot-value to 'name) (slot-value from 'name))))
+ (:method progn ((from ns-node) (to ns-node))
+ (unless (slot-boundp to 'value)
+ (setf (slot-value to 'value) (slot-value from 'value)))
+ (unless (slot-boundp to 'namespace)
+ (setf (slot-value to 'namespace) (slot-value from 'namespace))))
+ (:method progn ((from attr-node) (to attr-node))
+ (unless (slot-boundp to 'value)
+ (setf (slot-value to 'value) (slot-value from 'value)))))
+
+;;
+;;
+;; constituent management for a document maintains the relation between the children
+;; and the root node. see also the respective check-constraint method
+
+(defMethod nodes ((node doc-node))
+ "for use with path interpretation"
+ (children node))
+
+(defMethod (setf nodes) (new-value (doc doc-node))
+ (setf (children doc) new-value))
+
+(defMethod (setf children) ((children sequence) (doc doc-node))
+ (with-slots (root) doc
+ (setf root (find-if #'is-abstract-elem-node children))
+ (call-next-method)))
+
+(defGeneric document (node)
+ (:method ((node doc-node)) node)
+ (:method ((node t)) nil))
+
+(defMethod def ((node elem-node) &aux document)
+ (with-slots (def name) node
+ (or (call-next-method)
+ (setf def (when (and name (setf document (document node)))
+ (find-def-elem-type name document))))))
+
+(defGeneric definition (x)
+ (:method ((x t)) (def x)))
+
+;;
+;;
+;; initialize property bits in a type definition
+
+(defMethod is-required ((def def-elem-property-type))
+ (eq (stipulation def) :REQUIRED))
+(defMethod is-implied ((def def-elem-property-type))
+ (eq (stipulation def) :IMPLIED))
+(defMethod is-fixed ((def def-elem-property-type))
+ (eq (stipulation def) :FIXED))
+(defMethod is-defaulted ((def def-elem-property-type))
+ (with-slots (prototype) def
+ (and prototype (children prototype))))
+
+(defMethod is-required ((node elem-property-node))
+ (with-slots (def) node (when def (is-required def))))
+(defMethod is-implied ((node elem-property-node))
+ (with-slots (def) node (when def (is-implied def))))
+(defMethod is-fixed ((node elem-property-node))
+ (with-slots (def) node (when def (is-fixed def))))
+(defMethod is-defaulted ((node elem-property-node))
+ (with-slots (children) node
+ children))
+
+(defMethod props-defaulted ((def def-elem-type))
+ (with-slots (properties props-defaulted) def
+ (or props-defaulted
+ (setf props-defaulted
+ (make-array (length properties) :element-type 'bit
+ :initial-contents
+ (mapcar #'(lambda (def) (if (is-defaulted def) 1 0))
+ properties))))))
+
+(defMethod props-required ((def def-elem-type))
+ (with-slots (properties props-required) def
+ (or props-required
+ (setf props-required
+ (make-array (length properties) :element-type 'bit
+ :initial-contents
+ (mapcar #'(lambda (def) (if (is-required def) 1 0))
+ properties))))))
+
+
+(defGeneric name-symbol (name)
+ (:method ((name symbol))
+ (if (keywordp name) (intern (string name) *package*) name))
+ (:method ((name uname))
+ (intern (local-part name)
+ (let* ((namespace (namespace name))
+ (package-name (namespace-name namespace)))
+ (if (eq namespace *null-namespace*)
+ *package*
+ (or (find-package package-name)
+ (error "package not found: ~s." package-name)))))))
+
+(defGeneric find-node-class (name)
+ (:method ((name symbol)) (find-class name nil))
+ (:method ((name uname)) (find-node-class (ignore-errors (name-symbol name)))))
+
+(defMethod node-class ((def def-elem-type))
+ (with-slots (node-class name) def
+ (or node-class
+ (cond ((and *specialize-elem-node*
+ (setf node-class (find-node-class name))
+ (subtypep (class-name node-class) 'abstract-elem-node))
+ node-class)
+ (t
+ (setf node-class *class.elem-node*))))))
+
+;(trace node-class)
+;(trace xmlp:construct-element-node)
+;;
+;;
+;; initialization
+
+(defMethod initialize-instance
+ ((instance entity-delegate) &rest initargs
+ &key entity-info uri
+ system-literal (system-id system-literal)
+ pubid-literal (public-id pubid-literal)
+ encoding-decl (encoding encoding-decl)
+ version-info (version version-info))
+ ;; keep name in sync. for doc-node this becomes the only binding
+ (when (listp entity-info)
+ (setf entity-info (apply #'make-entity-information-node entity-info)))
+ (when (is-entity-information-node entity-info)
+ (when uri (uri entity-info) uri)
+ (when system-id (setf (system-id entity-info) system-id))
+ (when public-id (setf (public-id entity-info) public-id))
+ (when encoding (setf (encoding entity-info) encoding))
+ (when version (setf (version entity-info) version)))
+ (apply #'call-next-method instance :entity-info entity-info initargs))
+
+(defMethod initialize-instance
+ ((instance entity-information-node) &key (defaults *xml-base*))
+ (with-slots (uri system-id public-id) instance
+ (call-next-method)
+ ;; generate the uri from the system and public identifiers
+ (unless uri
+ (setf uri (resolve-entity-identifiers public-id system-id defaults)))))
+
+
+(defMethod initialize-instance
+ ((instance doc-node) &rest initargs
+ &key declarations children (root (find-if #'is-abstract-elem-node children))
+ notations ids general-entities parameter-entities types attributes)
+ ;; integrate definitions for notation, entities and types.
+ ;; note that the attributes informational and thus not integrated. the effective
+ ;; definitions are in the types
+ (apply #'call-next-method instance
+ :root root :children (or children (when root (list root)))
+ initargs)
+ (when root (setf (parent root) instance))
+
+ (flet ((local-bind-definition (def) (bind-definition def instance)))
+ (etypecase notations
+ (hash-table (setf (notations instance) notations))
+ (cons (map nil #'local-bind-definition notations))
+ (null (map-node-by-type #'is-def-notation #'bind-definition declarations)))
+ (etypecase ids
+ (hash-table (setf (ids instance) ids))
+ (null t))
+ (etypecase general-entities
+ (hash-table (setf (general-entities instance) general-entities))
+ (cons (map nil #'local-bind-definition general-entities))
+ (null (map-node-by-type #'is-def-general-entity #'bind-definition declarations)))
+ (etypecase parameter-entities
+ (hash-table (setf (parameter-entities instance) general-entities))
+ (cons (map nil #'local-bind-definition parameter-entities))
+ (null (map-node-by-type #'is-def-parameter-entity #'bind-definition declarations)))
+ (etypecase types
+ (hash-table (setf (types instance) types))
+ (cons (map nil #'local-bind-definition types))
+ (null (map-node-by-type #'is-def-elem-type #'bind-definition declarations)))
+ (setf (attributes instance)
+ (etypecase attributes
+ (cons attributes)
+ (null (collect-attribute-declarations declarations))))
+ ))
+
+(defMethod initialize-instance
+ ((instance elem-node) &rest initargs
+ &key
+ (attributes nil attributes-p)
+ (namespaces nil namespaces-p)
+ (children nil children-p))
+ (apply #'call-next-method instance
+ :children nil
+ initargs)
+ (when attributes-p (setf (attributes instance) attributes))
+ (when namespaces-p (setf (namespaces instance) namespaces))
+ (when children-p (setf (children instance) children)))
+
+(defMethod (setf attributes) :before (attributes (instance elem-node))
+ (dolist (n attributes)
+ (etypecase n
+ (attr-node (setf (parent n) instance)))))
+
+(defMethod (setf namespaces) :before (namespaces (instance elem-node))
+ (dolist (n namespaces)
+ (etypecase n
+ (ns-node (setf (parent n) instance)))))
+
+(defMethod (setf children) :after (children (instance elem-node))
+ (declare (special |VC: Element Content|))
+ (slot-makunbound instance 'valid)
+ (dolist (n children)
+ (etypecase n
+ (elem-child-node (setf (parent n) instance))
+ (string )))
+ (when (validate? instance)
+ (check-constraint |VC: Element Content| instance)))
+
+(defMethod initialize-instance :after
+ ((instance ns-node) &key)
+ "upon instantiation, as ns-node generates the effective namespace name and ensures
+ that it exists."
+ (declare (special |NSC: Prefix Immutable|))
+ (with-slots (children value namespace name) instance
+ (when (string= (local-part name) *xmlns-prefix-namestring*)
+ (setf name *default-namespace-attribute-name*))
+ (when namespace
+ (setf value (namespace-name namespace)))
+ (etypecase value
+ (null
+ (setf value (value-string children)))
+ (string
+ (unless (and (stringp (first children))
+ (string= (first children) value)
+ (null (rest children)))
+ (setf children (list value)))))
+ (unless namespace
+ (setf namespace (find-namespace value :if-does-not-exist :create)))
+ (check-constraint |NSC: Prefix Immutable| instance)))
+
+#| 20010501, now in the parser only. in constructors for type and attr defs
+(defMethod initialize-instance :after
+ ((instance abstract-top-level-def-node) &key)
+ ;; cache declarations within each given physical entity
+ (push instance *entity-declarations*))
+|#
+
+(defMethod initialize-instance :after
+ ((instance def-elem-property-type) &key)
+ (with-slots (prototype children) instance
+ (when prototype (setf (def prototype) instance))
+ ;; 20010611 xml-V10-2e-errata#E2
+ (mapl #'(lambda (values)
+ (when (find (first values) (rest values) :test #'bnfp::name=)
+ (|VC: No Duplicate Tokens| :context instance :name (first values))))
+ children)))
+
+(defMethod initialize-instance :after
+ ((instance def-attr) &key)
+ (with-slots (children) instance
+ (dolist (def children)
+ (setf (parent def) instance))))
+
+;; nb, it would be nicer to note the when the entity is bound and to replace them _and_ longer
+;; entities which encode character entities with the effective character entity.
+;; the would require that the tokenizer recognize character entity instances.
+(defMethod initialize-instance :after
+ ((instance def-internal-entity) &key)
+ (with-slots (children) instance
+ ;; normalize and constraint the entity value
+ (when (stringp children)
+ (setf children (map 'list #'char-code children)))
+ ;; (print (list children (= 1 (length children)) (xml-markupchar? (or (first children) 0))))
+ (when (and (= 1 (length children)) (xml-markupchar? (first children)))
+ (setf children (map 'list #'char-code (format nil "&#~d;" (first children)))))))
+;;
+;;
+;;
+
+(defMethod print-object ((node named-node) stream)
+ (print-unreadable-object (node stream :type t :identity t)
+ (write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)))
+
+(defMethod print-object ((node doc-node) stream &aux uri)
+ (print-unreadable-object (node stream :type t :identity t)
+ (if (slot-boundp node 'entity-info)
+ (if (setf uri (uri node))
+ (write-string (uri-namestring uri) stream)
+ (write-string "<no uri>" stream))
+ (write-string "<no entity info>" stream))))
+
+(defMethod print-object ((instance qname-value) stream)
+ (with-slots (namespace name) instance
+ (format stream "{~@[~a~]}~a" (when namespace (namespace-name namespace)) name)))
+
+(defMethod print-object ((node elem-node) stream)
+ (print-unreadable-object (node stream :identity t :type t)
+ (format stream "~s~@[ ~s~]"
+ (when (slot-boundp node 'name) (slot-value node 'name))
+ (when (slot-boundp node 'ordinality) (slot-value node 'ordinality)))))
+
+(defMethod print-object ((node attr-node) stream)
+ (print-unreadable-object (node stream :identity t :type t)
+ (write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)))
+
+(defMethod print-object ((node ns-node) stream)
+ (print-unreadable-object (node stream :identity t :type t)
+ (write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)
+ (write-string " -> " stream)
+ (write (when (or (slot-boundp node 'value) (slot-boundp node 'children)) (value node))
+ :stream stream)))
+
+(defMethod print-object ((instance pi-node) stream &aux value trimmed)
+ (print-unreadable-object (instance stream :type t :identity t)
+ (prin1 (name instance) stream)
+ (setf value (value instance))
+ (write-string " '" stream)
+ (dotimes (i (length value))
+ (write-char (char value i) stream)
+ (when (> i 16) (setf trimmed t) (return)))
+ (if trimmed
+ (write-string "..." stream)
+ (write-char #\' stream))))
+
+(defMethod print-object ((instance def-internal-entity) stream
+ &aux children value)
+ (print-unreadable-object (instance stream :type t :identity t)
+ (prin1 (name instance) stream)
+ (cond ((setf children (children instance))
+ (write-string " '" stream)
+ (let ((i 0))
+ (block print-trimmed
+ (map nil #'(lambda (c)
+ (when (>= (incf i) 16) (return-from print-trimmed))
+ (write-char (code-char c) stream))
+ children))
+ (when (>= i 16)
+ (write-string "..." stream)))
+ (write-char #\' stream))
+ ((setf value (slot-value instance 'value))
+ (format stream " '~a'" value)))))
+
+(defMethod print-object ((node def-elem-type) stream
+ &aux (*print-pretty* t) (*print-right-margin* 1024))
+ (with-slots (name children) node
+ (print-unreadable-object (node stream :type t :identity t)
+ (write (when (slot-boundp node 'name) (slot-value node 'name)) :stream stream)
+ (if (typep children '|content-model|)
+ (princ children stream)
+ (format stream " ~a" children)))))
+
+(defMethod print-object ((node def-attr) stream)
+ (print-unreadable-object (node stream :type t :identity t)
+ (format stream "~/xqdm:print-qname/ ~(~/xqdm:print-qname/~^ ~)"
+ (when (slot-boundp node 'name) (slot-value node 'name))
+ (when (slot-boundp node 'children) (slot-value node 'children)))))
+
+(defMethod print-qname ((node named-node) (stream stream) &rest args)
+ (declare (dynamic-extent args))
+ (apply #'print-qname stream (name node) args))
+(defMethod print-qname ((stream stream) (node named-node) &rest args)
+ (declare (dynamic-extent args))
+ (apply #'print-qname stream (name node) args))
+(defMethod print-qname ((stream stream) (name abstract-name) &rest args)
+ (declare (ignore args))
+ (let ((prefix (prefix name))
+ (namespace (namespace-name name))
+ (extent (qname-extent name))
+ (local-part (local-part name)))
+ (etypecase namespace
+ (nameset (setf namespace (name namespace)))
+ (nameset-tokenizer (setf namespace (name namespace)))
+ (null t)
+ (string t))
+ (if namespace
+ (format stream "{~a}~a" namespace local-part)
+ (format stream "#~@[~a:~]~a" prefix local-part))
+ (when extent
+ (format stream "[~a]" extent))
+ name))
+(defMethod print-qname ((name abstract-name) (stream stream) &rest args)
+ (declare (dynamic-extent args))
+ (apply #'print-qname stream name args))
+
+
+
+
+(defGeneric print-ns-node (stream node &rest args)
+ (:method ((stream stream) (instance ns-node) &rest args)
+ (declare (ignore args))
+ (with-slots (name value) instance
+ (if *print-pretty*
+ (format stream "[~a~@[/~s~]]" name value)
+ (print-unreadable-object (instance stream :type t :identity t)
+ (format stream "~a~@[/~s~]"
+ name value)))))
+ (:method ((instance ns-node) (stream stream) &rest args)
+ (declare (dynamic-extent args))
+ (apply #'print-ns-node stream instance args)))
+
+
+(defParameter *context-print-level* 0)
+
+(defMethod print-content ((instance def-type-qname-context) stream)
+ (with-slots (name parents children content-names attr-nodes ns-nodes) instance
+ (format stream "~/xqdm:print-qname/" name)
+ (if (slot-boundp instance 'parents)
+ (format stream " (^:~{ ~/xqdm:print-qname/~})" (mapcar #'name parents))
+ (write-string " (^: #<UNBOUND>)" stream))
+ (format stream " (@:~{ ~/xqdm:print-qname/~})" (mapcar #'name attr-nodes))
+ (let ((*print-pretty* t))
+ (format stream " (ns:~{ ~/xqdm:print-ns-node/~})" ns-nodes))
+ (format stream " (m:~{ ~/xqdm:print-qname/~})" content-names)
+ (when children
+ (let ((*context-print-level* (+ *context-print-level* 2)))
+ (if *print-pretty*
+ (format stream "~{~%~a~}" children)
+ (format stream " ->(~{~/xqdm:print-qname/~^ ~})"
+ (mapcar #'name children)))))))
+
+(defMethod print-content ((instance def-attr-qname-context) stream
+ &aux (*print-pretty* t))
+ (with-slots (name attr-nodes ns-nodes assignment) instance
+ (format stream "~/xqdm:print-qname/" name)
+ (format stream " (@:~{ ~/xqdm:print-qname/~})" (mapcar #'name attr-nodes))
+ (format stream " (ns:~{ ~/xqdm:print-ns-node/~})" ns-nodes)
+ (if assignment
+ (format stream " ->~/xqdm:print-qname/" (name assignment))
+ (format stream " ->?"))))
+
+(defMethod print-object ((instance qname-context) stream)
+ (cond (*print-pretty*
+ (dotimes (i *context-print-level*) (write-char #\space stream))
+ (write-char #\[ stream)
+ (print-content instance stream)
+ (write-char #\] stream))
+ (t
+ (print-unreadable-object (instance stream :type t :identity t)
+ (print-content instance stream)))))
+
+
+
+
+#|
+(defparameter *test*
+ (sxml-element 'test
+ "asdf" (sxml-element 'test2 "qwer" "<>")))
+
+(write-node *test* *standard-output*)
+(element-bind (name value) entry (print (list name value)))
+(element.content (element.content-element *test* 'test2))
+
+(inspect
+ (with-input-from-string
+ (stream
+ "<?xml version='1.0'>
+ <!DOCTYPE asdf [<!ELEMENT asdf #PCDATA>]>
+ <asdf attribute1='first' attribute2='second'>
+ testing&one;
+ </asdf>")
+ (|Document-Parser| stream)))
+(write-node (top-inspect-form) *standard-output*)
+ |#
+
+:EOF
1
0
14 Feb '06
Author: banderson
Date: Tue Feb 14 10:32:37 2006
New Revision: 7
Removed:
branches/sbcl-0.9.x-testing/atn-parser/
Log:
some re-arranging from old releases
1
0
Author: banderson
Date: Tue Feb 14 10:32:22 2006
New Revision: 6
Removed:
branches/sbcl-0.9.x-testing/define-system.lisp
Log:
some re-arranging from old releases
1
0
Author: banderson
Date: Mon Feb 13 13:05:26 2006
New Revision: 5
Added:
branches/sbcl-0.9.x-testing/
- copied from r4, trunk/
Log:
start branch for getting SBCL to compile/load the lib
1
0
Author: banderson
Date: Wed Feb 8 17:58:17 2006
New Revision: 3
Added:
tags/0.918/
- copied from r2, trunk/
Log:
tagging the 0.918 release
1
0
Author: banderson
Date: Tue Feb 7 10:09:22 2006
New Revision: 1
Added:
branches/
tags/
trunk/
Log:
basic repos structure
1
0